diff options
Diffstat (limited to 'lisp/emacs-lisp')
27 files changed, 882 insertions, 254 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index aaacba2c8e5..148fb70981f 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -393,6 +393,8 @@ FILE's name." (concat ";;; " basename " --- automatically extracted " (or type "autoloads") " -*- lexical-binding: t -*-\n" + (when (equal basename "loaddefs.el") + ";; This file will be copied to ldefs-boot.el and checked in periodically.\n") ";;\n" ";;; Code:\n\n" (if lp diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c8990f23531..9c64083b64b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1186,6 +1186,72 @@ See Info node `(elisp) Integer Basics'." (put 'concat 'byte-optimizer #'byte-optimize-concat) +(defun byte-optimize-define-key (form) + "Expand key bindings in FORM." + (let ((key (nth 2 form))) + (if (and (vectorp key) + (= (length key) 1) + (stringp (aref key 0))) + ;; We have key on the form ["C-c C-c"]. + (if (not (kbd-valid-p (aref key 0))) + (error "Invalid `kbd' syntax: %S" key) + (list (nth 0 form) (nth 1 form) + (kbd (aref key 0)) (nth 4 form))) + ;; No improvement. + form))) + +(put 'define-key 'byte-optimizer #'byte-optimize-define-key) + +(defun byte-optimize-define-keymap (form) + "Expand key bindings in FORM." + (let ((result nil) + (orig-form form) + improved) + (push (pop form) result) + (while (and form + (keywordp (car form)) + (not (eq (car form) :menu))) + (unless (memq (car form) + '(:full :keymap :parent :suppress :name :prefix)) + (error "Invalid keyword: %s" (car form))) + (push (pop form) result) + (when (null form) + (error "Uneven number of keywords in %S" form)) + (push (pop form) result)) + ;; Bindings. + (while form + (let ((key (pop form))) + (if (and (vectorp key) + (= (length key) 1) + (stringp (aref key 0))) + (progn + (unless (kbd-valid-p (aref key 0)) + (error "Invalid `kbd' syntax: %S" key)) + (push (kbd (aref key 0)) result) + (setq improved t)) + ;; No improvement. + (push key result))) + (when (null form) + (error "Uneven number of key bindings in %S" form)) + (push (pop form) result)) + (if improved + (nreverse result) + orig-form))) + +(defun byte-optimize-define-keymap--define (form) + "Expand key bindings in FORM." + (if (not (consp (nth 1 form))) + form + (let ((optimized (byte-optimize-define-keymap (nth 1 form)))) + (if (eq optimized (nth 1 form)) + ;; No improvement. + form + (list (car form) optimized))))) + +(put 'define-keymap 'byte-optimizer #'byte-optimize-define-keymap) +(put 'define-keymap--define 'byte-optimizer + #'byte-optimize-define-keymap--define) + ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, @@ -1261,7 +1327,7 @@ See Info node `(elisp) Integer Basics'." (list 'or (car (car clauses)) (byte-optimize-cond (cons (car form) (cdr (cdr form))))) - form)) + (and clauses form))) form)) (defun byte-optimize-if (form) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index da86fa5cecf..d82d9454e84 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -380,7 +380,7 @@ You don't need this. (See bytecomp.el commentary for more details.) "Define an inline function. The syntax is just like that of `defun'. \(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - (declare (debug defun) (doc-string 3)) + (declare (debug defun) (doc-string 3) (indent 2)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) @@ -434,7 +434,7 @@ WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number. See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) @@ -483,7 +483,7 @@ For the benefit of Customize, if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: `saved-value', `saved-variable-comment'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3f050d1b799..471a0b623ad 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -299,7 +299,7 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings) + docstrings not-unused) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -321,6 +321,7 @@ Elements of the list may be: lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. mapcar mapcar called for effect. + not-unused warning about using variables with symbol names starting with _. constants let-binding of, or assignment to, constants/nonvariables. docstrings docstrings that are too wide (longer than `byte-compile-docstring-max-column' or diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 0a6b04b4c1f..03e109f2508 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -608,10 +608,9 @@ FORM is the parent form that binds this var." (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) ;; FIXME: Convert this warning to use `macroexp--warn-wrap' - ;; so as to give better position information and obey - ;; `byte-compile-warnings'. - (byte-compile-warn - "%s `%S' not left unused" varkind var)) + ;; so as to give better position information. + (when (byte-compile-warning-enabled-p 'not-unused var) + (byte-compile-warn "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e03ddc4c666..7bb82c2e8bf 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -339,6 +339,7 @@ See Info node `(elisp) Documentation Tips' for background." ;; (setq checkdoc--argument-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional +;; (setq checkdoc-verb-check-experimental-flag nil) ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' (defvar checkdoc--argument-missing-flag t @@ -493,6 +494,9 @@ be re-created.") (defconst checkdoc--help-buffer "*Checkdoc Help*" "Name of buffer used for Checkdoc Help.") +(defvar checkdoc-commentary-header-string "\n;;; Commentary:\n;; \n\n" + "String inserted as commentary marker in `checkdoc-file-comments-engine'.") + ;;; User level commands ;; ;;;###autoload @@ -2125,13 +2129,11 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"." ;; a part of a list. (rx letter ".") (rx (or - ;; The abbreviations: + ;; The abbreviations (a trailing dot is added below). (seq (any "cC") "f") ; cf. (seq (any "eE") ".g") ; e.g. (seq (any "iI") "." (any "eE")) ; i.e. - "a.k.a" ; a.k.a. - "etc" ; etc. - "vs" ; vs. + "a.k.a" "etc" "vs" "N.B" ;; Some non-standard or less common ones that we ;; might as well accept. "Inc" "Univ" "misc" "resp") @@ -2410,7 +2412,7 @@ Code:, and others referenced in the style guide." nil nil t))) (if (checkdoc-y-or-n-p "You should have a \";;; Commentary:\", add one?") - (insert "\n;;; Commentary:\n;; \n\n") + (insert checkdoc-commentary-header-string) (checkdoc-create-error "You should have a section marked \";;; Commentary:\"" nil nil t))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 4834fb13c6a..9de47e4987d 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -86,6 +86,14 @@ ;;; Code: +;; We provide a mechanism to define new specializers. +;; Related work can be found in: +;; - http://www.p-cos.net/documents/filtered-dispatch.pdf +;; - Generalizers: New metaobjects for generalized dispatch +;; http://research.gold.ac.uk/9924/1/els-specializers.pdf +;; This second one is closely related to what we do here (and that's +;; the name "generalizer" comes from). + ;; The autoloads.el mechanism which adds package--builtin-versions ;; maintenance to loaddefs.el doesn't work for preloaded packages (such ;; as this one), so we have to do it by hand! @@ -100,6 +108,7 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-macs)) ;For cl--find-class. (eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) (cl-defstruct (cl--generic-generalizer (:constructor nil) @@ -589,19 +598,10 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) -(defmacro cl--generic-with-memoization (place &rest code) - (declare (indent 1) (debug t)) - (gv-letplace (getter setter) place - `(or ,getter - ,(macroexp-let2 nil val (macroexp-progn code) - `(progn - ,(funcall setter val) - ,val))))) - (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) (defun cl--generic-get-dispatcher (dispatch) - (cl--generic-with-memoization + (with-memoization (gethash dispatch cl--generic-dispatchers) ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) @@ -644,10 +644,13 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; overkill: better just use a `cl-typep' test. (byte-compile `(lambda (generic dispatches-left methods) + ;; FIXME: We should find a way to expand `with-memoize' once + ;; and forall so we don't need `subr-x' when we get here. + (eval-when-compile (require 'subr-x)) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@fixedargs &rest args) (let ,bindings - (apply (cl--generic-with-memoization + (apply (with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss generic ',dispatch-arg dispatches-left methods @@ -684,14 +687,14 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") +(define-error 'cl--generic-cyclic-definition "Cyclic definition") (defun cl--generic-build-combined-method (generic methods) (if (null methods) ;; Special case needed to fix a circularity during bootstrap. (cl--generic-standard-method-combination generic methods) (let ((f - (cl--generic-with-memoization + (with-memoization ;; FIXME: Since the fields of `generic' are modified, this ;; hash-table won't work right, because the hashes will change! ;; It's not terribly serious, but reduces the effectiveness of @@ -1143,7 +1146,7 @@ These match if the argument is a cons cell whose car is `eql' to VAL." ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) - (cl--generic-with-memoization + (with-memoization (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index d24ea355a51..59cbc0e50d5 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -244,30 +244,29 @@ contents of the minibuffer are \"alice,bob,eve\" and point is between This function returns a list of the strings that were read, with empty strings removed." - (unwind-protect - (progn - (add-hook 'choose-completion-string-functions - 'crm--choose-completion-string) - (let* ((minibuffer-completion-table #'crm--collection-fn) - (minibuffer-completion-predicate predicate) - ;; see completing_read in src/minibuf.c - (minibuffer-completion-confirm - (unless (eq require-match t) require-match)) - (crm-completion-table table) - (map (if require-match - crm-local-must-match-map - crm-local-completion-map)) - ;; If the user enters empty input, `read-from-minibuffer' - ;; returns the empty string, not DEF. - (input (read-from-minibuffer - prompt initial-input map - nil hist def inherit-input-method))) - (when (and def (string-equal input "")) - (setq input (if (consp def) (car def) def))) - ;; Remove empty strings in the list of read strings. - (split-string input crm-separator t))) - (remove-hook 'choose-completion-string-functions - 'crm--choose-completion-string))) + (let* ((map (if require-match + crm-local-must-match-map + crm-local-completion-map)) + input) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'choose-completion-string-functions + 'crm--choose-completion-string nil 'local) + (setq-local minibuffer-completion-table #'crm--collection-fn) + (setq-local minibuffer-completion-predicate predicate) + ;; see completing_read in src/minibuf.c + (setq-local minibuffer-completion-confirm + (unless (eq require-match t) require-match)) + (setq-local crm-completion-table table)) + (setq input (read-from-minibuffer + prompt initial-input map + nil hist def inherit-input-method))) + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. + (when (and def (string-equal input "")) + (setq input (if (consp def) (car def) def))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) ;; testing and debugging ;; (defun crm-init-test-environ () diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0592db85df4..163528acf6f 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -701,7 +701,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on entry to function (default all functions): " + (format-prompt "Cancel debug on entry to function" + "all functions") (mapcar #'symbol-name (debug--function-list)) nil t))) (when name (unless (string= name "") @@ -804,7 +805,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on set for variable (default all variables): " + (format-prompt "Cancel debug on set for variable" + "all variables") (mapcar #'symbol-name (debug--variable-list)) nil t))) (when name (unless (string= name "") diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index dd30846546b..af5eecc22a5 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -175,12 +175,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 4) - ;; Ask not what - ;;(indent 3) - ;; can do for you, ask what it can do to others. IOW, the - ;; missing of indentation setting here is the indentation - ;; setting and not an oversight. - ) + (indent defun)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f752861d80a..db86e0e0292 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -198,6 +198,7 @@ INIT-VALUE LIGHTER KEYMAP. \(fn MODE DOC [KEYWORD VAL ... &rest BODY])" (declare (doc-string 2) + (indent defun) (debug (&define name string-or-null-p [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp @@ -450,7 +451,7 @@ after running the major mode's hook. However, MODE is not turned on if the hook has explicitly disabled it. \(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" - (declare (doc-string 2)) + (declare (doc-string 2) (indent defun)) (let* ((global-mode-name (symbol-name global-mode)) (mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 4f3c05baa98..a38c8bd5ca9 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3519,7 +3519,8 @@ The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read - "Cancel edebug on entry to (default all functions): " + (format-prompt "Cancel edebug on entry to" + "all functions") (let ((functions (edebug--edebug-on-entry-functions))) (unless functions (user-error "No functions have `edebug-on-entry'")) @@ -4548,7 +4549,8 @@ instrumentation for, defaulting to all functions." (user-error "Found no functions to remove instrumentation from")) (let ((name (completing-read - "Remove instrumentation from (default all functions): " + (format-prompt "Remove instrumentation from" + "all functions") functions))) (if (and name (not (equal name ""))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 6d84839c341..60b0638c63f 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -70,7 +70,8 @@ is appropriate to use. Uses `defmethod' to create methods, and calls `defgeneric' for you. With this implementation the ARGS are currently ignored. You can use `defgeneric' to apply specialized top level documentation to a method." - (declare (doc-string 3) (obsolete cl-defgeneric "25.1")) + (declare (doc-string 3) (obsolete cl-defgeneric "25.1") + (indent defun)) `(eieio--defalias ',method (eieio--defgeneric-init-form ',method @@ -103,6 +104,7 @@ Summary: \"doc-string\" body)" (declare (doc-string 3) (obsolete cl-defmethod "25.1") + (indent defun) (debug (&define ; this means we are defining something [&name sexp] ;Allow (setf ...) additionally to symbols. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 80d1711d817..7c5babcf54c 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -478,7 +478,8 @@ See `defclass' for more information." ;; (dotimes (cnt (length cslots)) ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) (dotimes (cnt (length slots)) - (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) + (+ (eval-when-compile eieio--object-num-slots) cnt))) (setf (eieio--class-index-table newc) oa)) ;; Set up a specialized doc string. @@ -508,6 +509,7 @@ See `defclass' for more information." ;; Create the cached default object. (let ((cache (make-record newc (+ (length (eieio--class-slots newc)) + ;; FIXME: Why +1 -1 ? (eval-when-compile eieio--object-num-slots) -1) nil))) @@ -747,7 +749,7 @@ Argument FN is the function calling this verifier." (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class)) + (cl-check-type obj (or eieio-object class cl-structure-object)) (let* ((class (cond ((symbolp obj) (error "eieio-oref called on a class: %s" obj) (eieio--full-class-object obj)) @@ -763,7 +765,7 @@ Argument FN is the function calling this verifier." ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. (slot-missing obj slot 'oref)) - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) @@ -892,7 +894,7 @@ reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call (let* ((fsi (gethash slot (eieio--class-index-table class)))) (if (integerp fsi) - (+ (eval-when-compile eieio--object-num-slots) fsi) + fsi (let ((fn (eieio--initarg-to-attribute class slot))) (if fn ;; Accessing a slot via its :initarg is accepted by EIEIO diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 2dc3e0aeffa..3fbfe011e29 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -110,7 +110,7 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) (cl-check-type superclasses list) (cond ((and (stringp (car options-and-doc)) @@ -359,9 +359,7 @@ variable name of the same name as the slot." (defun eieio-pcase-slot-index-from-index-table (index-table slot) "Find the index to pass to `aref' to access SLOT." - (let ((index (gethash slot index-table))) - (if index (+ (eval-when-compile eieio--object-num-slots) - index)))) + (gethash slot index-table)) (pcase-defmacro eieio (&rest fields) "Pcase patterns that match EIEIO object EXPVAL. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a1c3c3268f2..b30d3fc30f4 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -380,7 +380,14 @@ Also store it in `eldoc-last-message' and return that value." ;; 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)))) + (not (or executing-kbd-macro + (bound-and-true-p edebug-active) + ;; The following configuration shows "Matches..." in the + ;; echo area when point is after a closing bracket, which + ;; conflicts with eldoc. + (and show-paren-context-when-offscreen + (not (pos-visible-in-window-p + (overlay-end show-paren--overlay))))))) (defvar eldoc-documentation-functions nil diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 8c33b7c9948..fde7947a273 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -202,14 +202,13 @@ This variable is set by the master function.") (defvar elp-not-profilable ;; First, the functions used inside each instrumented function: '(called-interactively-p - ;; Then the functions used by the above functions. I used - ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x)) - ;; (aref (symbol-function 'elp-wrapper) 2))) - ;; to help me find this list. - error call-interactively apply current-time + ;; (delq + ;; nil (mapcar + ;; (lambda (x) (and (symbolp x) (fboundp x) x)) + ;; (aref (aref (aref (symbol-function 'elp--make-wrapper) 2) 1) 2))) + error apply current-time float-time time-subtract ;; Andreas Politz reports problems profiling these (Bug#4233): - + byte-code-function-p functionp byte-code subrp - indirect-function fboundp) + + byte-code-function-p functionp byte-code subrp fboundp) "List of functions that cannot be profiled. Those functions are used internally by the profiling code and profiling them would thus lead to infinite recursion.") diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 3fc57d5182d..7fc316d1469 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -352,7 +352,6 @@ convert it to a string and pass it to COLLECTOR first." (defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" "Regexp for `string-trim' (right) used by `ert-resource-directory'.") -;; Has to be a macro for `load-file-name'. (defmacro ert-resource-directory () "Return absolute file name of the resource (test data) directory. @@ -368,17 +367,17 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(let* ((testfile ,(or (macroexp-file-name) - buffer-file-name)) - (default-directory (file-name-directory testfile))) - (file-truename - (if (file-accessible-directory-p "resources/") - (expand-file-name "resources/") - (expand-file-name - (format ert-resource-directory-format - (string-trim testfile - ert-resource-directory-trim-left-regexp - ert-resource-directory-trim-right-regexp))))))) + `(when-let ((testfile ,(or (macroexp-file-name) + buffer-file-name))) + (let ((default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp)))))))) (defmacro ert-resource-file (file) "Return absolute file name of resource (test data) file named FILE. @@ -386,6 +385,96 @@ A resource file is defined as any file placed in the resource directory as returned by `ert-resource-directory'." `(expand-file-name ,file (ert-resource-directory))) +(defvar ert-temp-file-prefix "emacs-test-" + "Prefix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defvar ert-temp-file-suffix nil + "Suffix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defun ert--with-temp-file-generate-suffix (filename) + "Generate temp file suffix from FILENAME." + (thread-last + (file-name-base filename) + (replace-regexp-in-string (rx string-start + (group (+? not-newline)) + (regexp "-?tests?") + string-end) + "\\1") + (concat "-"))) + +(defmacro ert-with-temp-file (name &rest body) + "Bind NAME to the name of a new temporary file and evaluate BODY. +Delete the temporary file after BODY exits normally or +non-locally. NAME will be bound to the file name of the temporary +file. + +The following keyword arguments are supported: + +:prefix STRING If non-nil, pass STRING to `make-temp-file' as + the PREFIX argument. Otherwise, use the value of + `ert-temp-file-prefix'. + +:suffix STRING If non-nil, pass STRING to `make-temp-file' as the + SUFFIX argument. Otherwise, use the value of + `ert-temp-file-suffix'; if the value of that + variable is nil, generate a suffix based on the + name of the file that `ert-with-temp-file' is + called from. + +:text STRING If non-nil, pass STRING to `make-temp-file' as + the TEXT argument. + +See also `ert-with-temp-directory'." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type name symbol) + (let (keyw prefix suffix directory text extra-keywords) + (while (keywordp (setq keyw (car body))) + (setq body (cdr body)) + (pcase keyw + (:prefix (setq prefix (pop body))) + (:suffix (setq suffix (pop body))) + (:directory (setq directory (pop body))) + (:text (setq text (pop body))) + (_ (push keyw extra-keywords) (pop body)))) + (when extra-keywords + (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " "))) + (let ((temp-file (make-symbol "temp-file")) + (prefix (or prefix ert-temp-file-prefix)) + (suffix (or suffix ert-temp-file-suffix + (ert--with-temp-file-generate-suffix + (or (macroexp-file-name) buffer-file-name))))) + `(let* ((,temp-file (,(if directory 'file-name-as-directory 'identity) + (make-temp-file ,prefix ,directory ,suffix ,text))) + (,name ,(if directory + `(file-name-as-directory ,temp-file) + temp-file))) + (unwind-protect + (progn ,@body) + (ignore-errors + ,(if directory + `(delete-directory ,temp-file :recursive) + `(delete-file ,temp-file)))))))) + +(defmacro ert-with-temp-directory (name &rest body) + "Bind NAME to the name of a new temporary directory and evaluate BODY. +Delete the temporary directory after BODY exits normally or +non-locally. + +NAME is bound to the directory name, not the directory file +name. (In other words, it will end with the directory delimiter; +on Unix-like systems, it will end with \"/\".) + +The same keyword arguments are supported as in +`ert-with-temp-file' (which see), except for :text." + (declare (indent 1) (debug (symbolp body))) + (let ((tail body) keyw) + (while (keywordp (setq keyw (car tail))) + (setq tail (cddr tail)) + (pcase keyw (:text (error "Invalid keyword for directory: :text"))))) + `(ert-with-temp-file ,name + :directory t + ,@body)) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index b7d984374cb..8ebc81fd418 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -63,6 +63,7 @@ (require 'ewoc) (require 'find-func) (require 'pp) +(require 'map) ;;; UI customization options. @@ -88,23 +89,6 @@ Use nil for no limit (caution: backtrace lines can be very long)." :background "red3")) "Face used for unexpected results in the ERT results buffer.") - -;;; Copies/reimplementations of cl functions. - -(defun ert-equal-including-properties (a b) - "Return t if A and B have similar structure and contents. - -This is like `equal-including-properties' except that it compares -the property values of text properties structurally (by -recursing) rather than with `eq'. Perhaps this is what -`equal-including-properties' should do in the first place; see -Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." - ;; This implementation is inefficient. Rather than making it - ;; efficient, let's hope bug 6581 gets fixed so that we can delete - ;; it altogether. - (not (ert--explain-equal-including-properties a b))) - - ;;; Defining and locating tests. ;; The data structure that represents a test case. @@ -218,11 +202,7 @@ it has to be wrapped in `(eval (quote ...))'. `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) - :body (lambda () - ;; Use the value of `lexical-binding' in - ;; the source file when evaluating the body. - (let ((lexical-binding ,lexical-binding)) - ,@body)))) + :body (lambda () ,@body))) ',name)))) (defvar ert--find-test-regexp @@ -469,7 +449,7 @@ Errors during evaluation are caught and handled like nil." (defun ert--explain-equal-rec (a b) "Return a programmer-readable explanation of why A and B are not `equal'. -Returns nil if they are." +Return nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) (pcase a @@ -602,14 +582,9 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." (t (substring s 0 len))))) -;; TODO(ohler): Once bug 6581 is fixed, rename this to -;; `ert--explain-equal-including-properties-rec' and add a fast-path -;; wrapper like `ert--explain-equal'. -(defun ert--explain-equal-including-properties (a b) - "Explainer function for `ert-equal-including-properties'. - -Returns a programmer-readable explanation of why A and B are not -`ert-equal-including-properties', or nil if they are." +(defun ert--explain-equal-including-properties-rec (a b) + "Return explanation of why A and B are not `equal-including-properties'. +Return nil if they are." (if (not (equal a b)) (ert--explain-equal a b) (cl-assert (stringp a) t) @@ -631,15 +606,17 @@ Returns a programmer-readable explanation of why A and B are not ,(ert--abbreviate-string (substring-no-properties a (1+ i)) 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (cl-assert (equal-including-properties a b) t) - ))) -(put 'ert-equal-including-properties - 'ert-explainer - 'ert--explain-equal-including-properties) + finally (cl-assert (equal-including-properties a b) t)))) +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `equal-including-properties'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal-including-properties a b) + nil + (ert--explain-equal-including-properties-rec a b))) +(put 'equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) ;;; Implementation of `ert-info'. @@ -779,7 +756,8 @@ This mainly sets up debugger-related bindings." ;; handle ert errors. Once that's done, remove ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for ;; details. - (let ((debugger (lambda (&rest args) + (let ((lexical-binding t) + (debugger (lambda (&rest args) (ert--run-test-debugger test-execution-info args))) (debug-on-error t) @@ -2665,9 +2643,135 @@ To be used in the ERT results buffer." 'ert--activate-font-lock-keywords) nil) +(defun ert-test-erts-file (file &optional transform) + "Parse FILE as a file containing before/after parts. +TRANSFORM will be called to get from before to after." + (with-temp-buffer + (insert-file-contents file) + (let ((gen-specs (list (cons 'dummy t) + (cons 'code transform)))) + ;; Find the start of a test. + (while (re-search-forward "^=-=\n" nil t) + (setq gen-specs (ert-test--erts-test gen-specs file)) + ;; Search to the end of the test. + (re-search-forward "^=-=-=\n"))))) + +(defun ert-test--erts-test (gen-specs file) + (let* ((file-buffer (current-buffer)) + (specs (ert--erts-specifications (match-beginning 0))) + (name (cdr (assq 'name specs))) + (start-before (point)) + (end-after (if (re-search-forward "^=-=-=\n" nil t) + (match-beginning 0) + (point-max))) + (skip (cdr (assq 'skip specs))) + end-before start-after + after after-point) + (unless name + (error "No name for test case")) + (if (and skip + (eval (car (read-from-string skip)))) + ;; Skipping this test. + () + ;; Do the test. + (goto-char end-after) + ;; We have a separate after section. + (if (re-search-backward "^=-=\n" start-before t) + (setq end-before (match-beginning 0) + start-after (match-end 0)) + (setq end-before end-after + start-after start-before)) + ;; Update persistent specs. + (when-let ((point-char (assq 'point-char specs))) + (setq gen-specs + (map-insert gen-specs 'point-char (cdr point-char)))) + (when-let ((code (cdr (assq 'code specs)))) + (setq gen-specs + (map-insert gen-specs 'code (car (read-from-string code))))) + ;; Get the "after" strings. + (with-temp-buffer + (insert-buffer-substring file-buffer start-after end-after) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Get the expected "after" point. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (goto-char (point-min)) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq after-point (point)))) + (setq after (buffer-string))) + ;; Do the test. + (with-temp-buffer + (insert-buffer-substring file-buffer start-before end-before) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (goto-char (point-min)) + ;; Place point in the specified place. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (let ((code (cdr (assq 'code gen-specs)))) + (unless code + (error "No code to run the transform")) + (funcall code)) + (unless (equal (buffer-string) after) + (ert-fail (list (format "Mismatch in test \"%s\", file %s" + name file) + (buffer-string) + after))) + (when (and after-point + (not (= after-point (point)))) + (ert-fail (list (format "Point wrong in test \"%s\", expected point %d, actual %d, file %s" + name + after-point (point) + file) + (buffer-string))))))) + ;; Return the new value of the general specifications. + gen-specs) + +(defun ert--erts-unquote () + (goto-char (point-min)) + (while (re-search-forward "^\\=-=\\(-=\\)$" nil t) + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + +(defun ert--erts-specifications (end) + "Find specifications before point (back to the previous test)." + (save-excursion + (goto-char end) + (goto-char + (if (re-search-backward "^=-=-=\n" nil t) + (match-end 0) + (point-min))) + (let ((specs nil)) + (while (< (point) end) + (if (looking-at "\\([^ \n\t:]+\\):\\([ \t]+\\)?\\(.*\\)") + (let ((name (intern (downcase (match-string 1)))) + (value (match-string 3))) + (forward-line 1) + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value (match-string 1))) + (forward-line 1)) + (push (cons name (substring-no-properties value)) specs)) + (forward-line 1))) + (nreverse specs)))) + (defvar ert-unload-hook ()) (add-hook 'ert-unload-hook #'ert--unload-function) +;;; Obsolete + +(define-obsolete-function-alias 'ert-equal-including-properties + #'equal-including-properties "29.1") +(put 'ert-equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) (provide 'ert) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index d6272a52469..ebcc63cc2a5 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -74,7 +74,7 @@ ;; (defvar gv--macro-environment nil ;; "Macro expanders for generalized variables.") -(define-error 'gv-invalid-place "%S is not a valid place expression") +(define-error 'gv-invalid-place "Invalid place expression") ;;;###autoload (defun gv-get (place do) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index bb00a97f8e3..d90d0f5f6ac 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -29,6 +29,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (defvar font-lock-comment-face) (defvar font-lock-doc-face) @@ -590,6 +591,8 @@ containing STARTPOS." (defun lisp-string-after-doc-keyword-p (listbeg startpos) "Return non-nil if `:documentation' symbol ends at STARTPOS inside a list. +`:doc' can also be used. + LISTBEG is the position of the start of the innermost list containing STARTPOS." (and listbeg ; We are inside a Lisp form. @@ -597,7 +600,7 @@ containing STARTPOS." (goto-char startpos) (ignore-errors (progn (backward-sexp 1) - (looking-at ":documentation\\_>")))))) + (looking-at ":documentation\\_>\\|:doc\\_>")))))) (defun lisp-font-lock-syntactic-face-function (state) "Return syntactic face function for the position represented by STATE. @@ -1106,6 +1109,53 @@ is the buffer position of the start of the containing expression." (t normal-indent)))))) +(defun lisp--local-defform-body-p (state) + "Return non-nil when at local definition body according to STATE. +STATE is the `parse-partial-sexp' state for current position." + (when-let ((start-of-innermost-containing-list (nth 1 state))) + (let* ((parents (nth 9 state)) + (first-cons-after (cdr parents)) + (second-cons-after (cdr first-cons-after)) + first-order-parent second-order-parent) + (while second-cons-after + (when (= start-of-innermost-containing-list + (car second-cons-after)) + (setq second-order-parent (pop parents) + first-order-parent (pop parents) + ;; Leave the loop. + second-cons-after nil)) + (pop second-cons-after) + (pop parents)) + (when second-order-parent + (let (local-definitions-starting-point) + (and (save-excursion + (goto-char (1+ second-order-parent)) + (when-let ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) + (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* + cl-symbol-macrolet)) + ;; In what follows, we rely on (point) returning non-nil. + (setq local-definitions-starting-point + (progn + (parse-partial-sexp + (point) first-order-parent nil + ;; From docstring of `parse-partial-sexp': + ;; Fourth arg non-nil means stop + ;; when we come to any character + ;; that starts a sexp. + t) + (point)))))) + (save-excursion + (when (ignore-errors + ;; We rely on `backward-up-list' working + ;; even when sexp is incomplete βto the rightβ. + (backward-up-list 2) + t) + (= local-definitions-starting-point (point)))))))))) + (defun lisp-indent-function (indent-point state) "This function is the normal value of the variable `lisp-indent-function'. The function `calculate-lisp-indent' calls this to determine @@ -1139,16 +1189,19 @@ Lisp function does not specify a special indentation." (if (and (elt state 2) (not (looking-at "\\sw\\|\\s_"))) ;; car of form doesn't seem to be a symbol - (progn + (if (lisp--local-defform-body-p state) + ;; We nevertheless check whether we are in flet-like form + ;; as we presume local function names could be non-symbols. + (lisp-indent-defform state indent-point) (if (not (> (save-excursion (forward-line 1) (point)) calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are ;; inside the innermost containing sexp. (backward-prefix-chars) (current-column)) @@ -1159,15 +1212,14 @@ Lisp function does not specify a special indentation." 'lisp-indent-function) (get (intern-soft function) 'lisp-indent-hook))) (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) + ;; Check whether we are in flet-like form. + (lisp--local-defform-body-p state)) (lisp-indent-defform state indent-point)) ((integerp method) (lisp-indent-specform method state indent-point normal-indent)) (method - (funcall method indent-point state))))))) + (funcall method indent-point state))))))) (defcustom lisp-body-indent 2 "Number of columns to indent the second line of a `(def...)' form." @@ -1235,6 +1287,13 @@ Lisp function does not specify a special indentation." (put 'autoload 'lisp-indent-function 'defun) ;Elisp (put 'progn 'lisp-indent-function 0) +(put 'defvar 'lisp-indent-function 'defun) +(put 'defalias 'lisp-indent-function 'defun) +(put 'defvaralias 'lisp-indent-function 'defun) +(put 'defconst 'lisp-indent-function 'defun) +(put 'define-category 'lisp-indent-function 'defun) +(put 'define-charset-internal 'lisp-indent-function 'defun) +(put 'define-fringe-bitmap 'lisp-indent-function 'defun) (put 'prog1 'lisp-indent-function 1) (put 'save-excursion 'lisp-indent-function 0) ;Elisp (put 'save-restriction 'lisp-indent-function 0) ;Elisp diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index 3166d33e029..450cdaa7a84 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -31,7 +31,7 @@ (require 'subr-x) (require 'cl-lib) -(defvar memory-report--type-size (make-hash-table)) +(defvar memory-report--type-size nil) ;;;###autoload (defun memory-report () @@ -84,6 +84,7 @@ by counted more than once." (gethash 'object memory-report--type-size))) (defun memory-report--set-size (elems) + (setq memory-report--type-size (make-hash-table)) (setf (gethash 'string memory-report--type-size) (cadr (assq 'strings elems))) (setf (gethash 'cons memory-report--type-size) @@ -282,7 +283,7 @@ by counted more than once." buffers) do (insert (memory-report--format size) " " - (button-buttonize + (buttonize (buffer-name buffer) #'memory-report--buffer-details buffer) "\n")) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2c37e19980d..08dfe504d27 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -714,6 +714,7 @@ REQUIREMENTS is a list of dependencies on other packages. where OTHER-VERSION is a string. EXTRA-PROPERTIES is currently unused." + (declare (indent defun)) ;; FIXME: Placeholder! Should we keep it? (error "Don't call me!")) @@ -757,47 +758,47 @@ PKG-DESC is a `package-desc' object." (format "%s-autoloads" (package-desc-name pkg-desc)) (package-desc-dir pkg-desc))) -(defun package--activate-autoloads-and-load-path (pkg-desc) - "Load the autoloads file and add package dir to `load-path'. -PKG-DESC is a `package-desc' object." - (let* ((old-lp load-path) - (pkg-dir (package-desc-dir pkg-desc)) - (pkg-dir-dir (file-name-as-directory pkg-dir))) - (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - (when (and (eq old-lp load-path) - (not (or (member pkg-dir load-path) - (member pkg-dir-dir load-path)))) - ;; Old packages don't add themselves to the `load-path', so we have to - ;; do it ourselves. - (push pkg-dir load-path)))) - (defvar Info-directory-list) (declare-function info-initialize "info" ()) (defvar package--quickstart-pkgs t "If set to a list, we're computing the set of pkgs to activate.") -(defun package--load-files-for-activation (pkg-desc reload) - "Load files for activating a package given by PKG-DESC. -Load the autoloads file, and ensure `load-path' is setup. If -RELOAD is non-nil, also load all files in the package that -correspond to previously loaded files." - (let* ((loaded-files-list - (when reload - (package--list-loaded-files (package-desc-dir pkg-desc))))) - ;; Add to load path, add autoloads, and activate the package. - (package--activate-autoloads-and-load-path pkg-desc) - ;; Call `load' on all files in `package-desc-dir' already present in - ;; `load-history'. This is done so that macros in these files are updated - ;; to their new definitions. If another package is being installed which - ;; depends on this new definition, not doing this update would cause - ;; compilation errors and break the installation. - (with-demoted-errors "Error in package--load-files-for-activation: %s" - (mapc (lambda (feature) (load feature nil t)) - ;; Skip autoloads file since we already evaluated it above. - (remove (file-truename (package--autoloads-file-name pkg-desc)) - loaded-files-list))))) +(defsubst package--library-stem (file) + (catch 'done + (let (result) + (dolist (suffix (get-load-suffixes) file) + (setq result (string-trim file nil suffix)) + (unless (equal file result) + (throw 'done result)))))) + +(defun package--reload-previously-loaded (pkg-desc) + "Force reimportation of files in PKG-DESC already present in `load-history'. +New editions of files contain macro definitions and +redefinitions, the overlooking of which would cause +byte-compilation of the new package to fail." + (with-demoted-errors "Error in package--load-files-for-activation: %s" + (let* (result + (dir (package-desc-dir pkg-desc)) + (load-path-sans-dir + (cl-remove-if (apply-partially #'string= dir) + (or (bound-and-true-p find-function-source-path) + load-path))) + (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (history (mapcar #'file-truename + (cl-remove-if-not #'stringp + (mapcar #'car load-history))))) + (dolist (file files) + (when-let ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil load-path-sans-dir)) + (found (member (file-truename canonical) history)) + (recent-index (length found))) + (unless (equal (file-name-base library) + (format "%s-autoloads" (package-desc-name pkg-desc))) + (push (cons (expand-file-name library dir) recent-index) result)))) + (mapc (lambda (c) (load (car c) nil t)) + (sort result (lambda (x y) (< (cdr x) (cdr y)))))))) (defun package-activate-1 (pkg-desc &optional reload deps) "Activate package given by PKG-DESC, even if it was already active. @@ -824,7 +825,11 @@ correspond to previously loaded files (those returned by (if (listp package--quickstart-pkgs) ;; We're only collecting the set of packages to activate! (push pkg-desc package--quickstart-pkgs) - (package--load-files-for-activation pkg-desc reload)) + (when reload + (package--reload-previously-loaded pkg-desc)) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) nil t)) + (add-to-list 'load-path (directory-file-name pkg-dir))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -835,48 +840,6 @@ correspond to previously loaded files (those returned by ;; Don't return nil. t))) -(defun package--files-load-history () - (delq nil - (mapcar (lambda (x) - (let ((f (car x))) - (and (stringp f) - (file-name-sans-extension (file-truename f))))) - load-history))) - -(defun package--list-of-conflicts (dir history) - (require 'find-func) - (declare-function find-library-name "find-func" (library)) - (delq - nil - (mapcar - (lambda (x) (let* ((file (file-relative-name x dir)) - ;; Previously loaded file, if any. - (previous - (ignore-error file-error ;"Can't find library" - (file-name-sans-extension - (file-truename (find-library-name file))))) - (pos (when previous (member previous history)))) - ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) - (when pos - (cons (file-name-sans-extension file) (length pos))))) - (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) - -(defun package--list-loaded-files (dir) - "Recursively list all files in DIR which correspond to loaded features. -Returns the `file-name-sans-extension' of each file, relative to -DIR, sorted by most recently loaded last." - (let* ((history (package--files-load-history)) - (dir (file-truename dir)) - ;; List all files that have already been loaded. - (list-of-conflicts (package--list-of-conflicts dir history))) - ;; Turn the list of (FILENAME . POS) back into a list of features. Files in - ;; subdirectories are returned relative to DIR (so not actually features). - (let ((default-directory (file-name-as-directory dir))) - (mapcar (lambda (x) (file-truename (car x))) - (sort list-of-conflicts - ;; Sort the files by ascending HISTORY-POSITION. - (lambda (x y) (< (cdr x) (cdr y)))))))) - ;;;; `package-activate' (defun package--get-activatable-pkg (pkg-name) @@ -995,7 +958,7 @@ untar into a directory named DIR; otherwise, signal an error." (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. - (package--load-files-for-activation new-desc :reload))) + (package--reload-previously-loaded new-desc))) pkg-dir)) (defun package-generate-description-file (pkg-desc pkg-file) @@ -2488,6 +2451,15 @@ The description is read from the installed package files." (format "%s.el" (package-desc-name desc)) srcdir)) ""))) +(defun package--describe-add-library-links () + "Add links to library names in package description." + (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) + (if (locate-library (match-string 1)) + (make-text-button (match-beginning 1) (match-end 1) + 'xref (match-string-no-properties 1) + 'help-echo "Read this file's commentary" + :type 'package--finder-xref)))) + (defun describe-package-1 (pkg) "Insert the package description for PKG. Helper function for `describe-package'." @@ -2714,6 +2686,9 @@ Helper function for `describe-package'." t) (insert (or readme-string "This package does not provide a description."))))) + ;; Make library descriptions into links. + (goto-char start-of-description) + (package--describe-add-library-links) ;; Make URLs in the description into links. (goto-char start-of-description) (browse-url-add-buttons)))) @@ -2759,6 +2734,15 @@ function is a convenience wrapper used by `describe-package-1'." (apply #'insert-text-button button-text 'face button-face 'follow-link t properties))) +(defun package--finder-goto-xref (button) + "Jump to a Lisp file for the BUTTON at point." + (let* ((file (button-get button 'xref)) + (lib (locate-library file))) + (if lib (finder-commentary lib) + (message "Unable to locate `%s'" file)))) + +(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref) + (defun package--print-email-button (recipient) "Insert a button whose action will send an email to RECIPIENT. NAME should have the form (FULLNAME . EMAIL) where FULLNAME is @@ -4195,6 +4179,7 @@ activations need to be changed, such as when `package-load-list' is modified." (replace-match (if (match-end 1) "" pfile) t t))) (unless (bolp) (insert "\n")) (insert ")\n"))) + (pp `(defvar package-activated-list) (current-buffer)) (pp `(setq package-activated-list (append ',(mapcar #'package-desc-name package--quickstart-pkgs) package-activated-list)) @@ -4212,6 +4197,7 @@ activations need to be changed, such as when `package-load-list' is modified." ;; Local\sVariables: ;; version-control: never ;; no-update-autoloads: t +;; byte-compile-warnings: (not make-local) ;; End: ")) ;; FIXME: Do it asynchronously in an Emacs subprocess, and diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 0bf774dffd8..8464b5a5198 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -33,22 +33,43 @@ (defcustom pp-escape-newlines t "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean) + +(defcustom pp-max-width t + "Max width to use when formatting. +If nil, there's no max width. If t, use the window width. +Otherwise this should be a number." + :type '(choice (const :tag "none" nil) + (const :tag "window width" t) + number) + :version "29.1") + +(defcustom pp-use-max-width nil + "If non-nil, `pp'-related functions will try to fold lines. +The target width is given by the `pp-max-width' variable." :type 'boolean - :group 'pp) + :version "29.1") + +(defvar pp--inhibit-function-formatting nil) ;;;###autoload (defun pp-to-string (object) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed to make output that `read' can handle, whenever this is possible." - (with-temp-buffer - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t)) - (prin1 object (current-buffer))) - (pp-buffer) - (buffer-string))) + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) + (with-temp-buffer + (pp-emacs-lisp-code object) + (buffer-string))) + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t)) + (prin1 object (current-buffer))) + (pp-buffer) + (buffer-string)))) ;;;###autoload (defun pp-buffer () @@ -56,7 +77,6 @@ to make output that `read' can handle, whenever this is possible." (interactive) (goto-char (point-min)) (while (not (eobp)) - ;; (message "%06d" (- (point-max) (point))) (cond ((ignore-errors (down-list 1) t) (save-excursion @@ -82,11 +102,21 @@ to make output that `read' can handle, whenever this is possible." "Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see)." (princ (pp-to-string object) (or stream standard-output))) -(defun pp-display-expression (expression out-buffer-name) +;;;###autoload +(defun pp-display-expression (expression out-buffer-name &optional lisp) "Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + If a temporary buffer is needed for representation, it will be named after OUT-BUFFER-NAME." (let* ((old-show-function temp-buffer-show-function) @@ -110,11 +140,13 @@ after OUT-BUFFER-NAME." (select-window window) (run-hooks 'temp-buffer-show-hook)) (when (window-live-p old-selected) - (select-window old-selected)) - (message "See buffer %s." out-buffer-name))) + (select-window old-selected)))) (message "%s" (buffer-substring (point-min) (point)))))))) (with-output-to-temp-buffer out-buffer-name - (pp expression) + (if lisp + (with-current-buffer standard-output + (pp-emacs-lisp-code expression)) + (pp expression)) (with-current-buffer standard-output (emacs-lisp-mode) (setq buffer-read-only nil) @@ -179,6 +211,188 @@ Ignores leading comment characters." (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) (pp-macroexpand-expression (pp-last-sexp)))) +;;;###autoload +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length." + (require 'edebug) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf)))) + +(defun pp--insert-lisp (sexp) + (cl-case (type-of sexp) + (vector (pp--format-vector sexp)) + (cons (cond + ((consp (cdr sexp)) + (if (and (length= sexp 2) + (eq (car sexp) 'quote)) + (cond + ((symbolp (cadr sexp)) + (let ((print-quoted t)) + (prin1 sexp (current-buffer)))) + ((consp (cadr sexp)) + (insert "'") + (pp--format-list (cadr sexp) + (set-marker (make-marker) (1- (point)))))) + (pp--format-list sexp))) + (t + (princ sexp (current-buffer))))) + ;; Print some of the smaller integers as characters, perhaps? + (integer + (if (<= ?0 sexp ?z) + (let ((print-integers-as-characters t)) + (princ sexp (current-buffer))) + (princ sexp (current-buffer)))) + (string + (let ((print-escape-newlines t)) + (prin1 sexp (current-buffer)))) + (otherwise (princ sexp (current-buffer))))) + +(defun pp--format-vector (sexp) + (insert "[") + (cl-loop for i from 0 + for element across sexp + do (pp--insert (and (> i 0) " ") element)) + (insert "]")) + +(defun pp--format-list (sexp &optional start) + (if (and (symbolp (car sexp)) + (not pp--inhibit-function-formatting) + (not (keywordp (car sexp)))) + (pp--format-function sexp) + (insert "(") + (pp--insert start (pop sexp)) + (while sexp + (pp--insert " " (pop sexp))) + (insert ")"))) + +(defun pp--format-function (sexp) + (let* ((sym (car sexp)) + (edebug (get sym 'edebug-form-spec)) + (indent (get sym 'lisp-indent-function)) + (doc (get sym 'doc-string-elt))) + (when (eq indent 'defun) + (setq indent 2)) + ;; We probably want to keep all the elements before the doc string + ;; on a single line. + (when doc + (setq indent (1- doc))) + ;; Special-case closures -- these shouldn't really exist in actual + ;; source code, so there's no indentation information. But make + ;; them output slightly better. + (when (and (not indent) + (eq sym 'closure)) + (setq indent 0)) + (pp--insert "(" sym) + (pop sexp) + ;; Get the first entries on the first line. + (if indent + (pp--format-definition sexp indent edebug) + (let ((prev 0)) + (while sexp + (let ((start (point))) + ;; Don't put sexps on the same line as a multi-line sexp + ;; preceding it. + (pp--insert (if (> prev 1) "\n" " ") + (pop sexp)) + (setq prev (count-lines start (point))))))) + (insert ")"))) + +(defun pp--format-definition (sexp indent edebug) + (while (and (cl-plusp indent) + sexp) + (insert " ") + ;; We don't understand all the edebug specs. + (unless (consp edebug) + (setq edebug nil)) + (if (and (consp (car edebug)) + (eq (caar edebug) '&rest)) + (pp--insert-binding (pop sexp)) + (if (null (car sexp)) + (insert "()") + (pp--insert-lisp (car sexp))) + (pop sexp)) + (pop edebug) + (cl-decf indent)) + (when (stringp (car sexp)) + (insert "\n") + (prin1 (pop sexp) (current-buffer))) + ;; Then insert the rest with line breaks before each form. + (while sexp + (insert "\n") + (if (keywordp (car sexp)) + (progn + (pp--insert-lisp (pop sexp)) + (when sexp + (pp--insert " " (pop sexp)))) + (pp--insert-lisp (pop sexp))))) + +(defun pp--insert-binding (sexp) + (insert "(") + (while sexp + (if (consp (car sexp)) + ;; Newlines after each (...) binding. + (progn + (pp--insert-lisp (car sexp)) + (when (cdr sexp) + (insert "\n"))) + ;; Keep plain symbols on the same line. + (pp--insert " " (car sexp))) + (pop sexp)) + (insert ")")) + +(defun pp--insert (delim &rest things) + (let ((start (if (markerp delim) + (prog1 + delim + (setq delim nil)) + (point-marker)))) + (when delim + (insert delim)) + (dolist (thing things) + (pp--insert-lisp thing)) + ;; We need to indent what we have so far to see if we have to fold. + (pp--indent-buffer) + (when (> (current-column) (pp--max-width)) + (save-excursion + (goto-char start) + (unless (looking-at "[ \t]+$") + (insert "\n")) + (pp--indent-buffer) + (goto-char (point-max)) + ;; If we're still too wide, then go up one step and try to + ;; insert a newline there. + (when (> (current-column) (pp--max-width)) + (condition-case () + (backward-up-list 1) + (:success (when (looking-back " " 2) + (insert "\n"))) + (error nil))))))) + +(defun pp--max-width () + (cond ((numberp pp-max-width) + pp-max-width) + ((null pp-max-width) + most-positive-fixnum) + ((eq pp-max-width t) + (window-width)) + (t + (error "Invalid pp-max-width value: %s" pp-max-width)))) + +(defun pp--indent-buffer () + (goto-char (point-min)) + (while (not (eobp)) + (lisp-indent-line) + (forward-line 1))) + (provide 'pp) ; so (require 'pp) works ;;; pp.el ends here diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 17ac3e471c0..a9f548b104e 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -71,6 +71,7 @@ string, it'll be inserted as is, then the string will be `read', and then evaluated. There can be any number of :example/:result elements." + (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -158,6 +159,8 @@ There can be any number of :example/:result elements." :eval (split-string-and-unquote "foo \"bar zot\"")) (split-string-shell-command :eval (split-string-shell-command "ls /tmp/'foo bar'")) + (string-glyph-split + :eval (string-glyph-split "Hello, πΌπ»π§πΌβπ€βπ§π»")) (string-lines :eval (string-lines "foo\n\nbar") :eval (string-lines "foo\n\nbar" t)) @@ -241,7 +244,14 @@ There can be any number of :example/:result elements." :eval (number-to-string 42)) "Data About Strings" (length - :eval (length "foo")) + :eval (length "foo") + :eval (length "avocado: π₯")) + (string-width + :eval (string-width "foo") + :eval (string-width "avocado: π₯")) + (string-pixel-width + :eval (string-pixel-width "foo") + :eval (string-pixel-width "avocado: π₯")) (string-search :eval (string-search "bar" "foobarzot")) (assoc-string @@ -271,6 +281,9 @@ There can be any number of :example/:result elements." :eval (file-name-base "/tmp/foo.txt")) (file-relative-name :eval (file-relative-name "/tmp/foo" "/tmp")) + (file-name-split + :eval (file-name-split "/tmp/foo") + :eval (file-name-split "foo/bar")) (make-temp-name :eval (make-temp-name "/tmp/foo-")) (file-name-concat @@ -348,6 +361,9 @@ There can be any number of :example/:result elements." (file-newer-than-file-p :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar") :eg-result nil) + (file-has-changed-p + :no-eval (file-has-changed-p "/tmp/foo") + :eg-result t) (file-equal-p :no-eval (file-equal-p "/tmp/foo" "/tmp/bar") :eg-result nil) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 788cd0f34bf..f336799040f 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -208,7 +208,9 @@ The variable list SPEC is the same as in `if-let'." (string= string "")) (defsubst string-join (strings &optional separator) - "Join all STRINGS using SEPARATOR." + "Join all STRINGS using SEPARATOR. +Optional argument SEPARATOR must be a string, a vector, or a list of +characters; nil stands for the empty string." (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -400,6 +402,68 @@ as the new values of the bound variables in the recursive invocation." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defmacro with-memoization (place &rest code) + "Return the value of CODE and stash it in PLACE. +If PLACE's value is non-nil, then don't bother evaluating CODE +and return the value found in PLACE instead." + (declare (indent 1) (debug (gv-place body))) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +;;;###autoload +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +;;;###autoload +(defun string-pixel-width (string) + "Return the width of STRING in pixels." + (with-temp-buffer + (insert string) + (car (window-text-pixel-size + (current-buffer) (point-min) (point))))) + +;;;###autoload +(defun string-glyph-split (string) + "Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters." + (let ((result nil) + (start 0) + comp) + (while (< start (length string)) + (if (setq comp (find-composition-internal start nil string nil)) + (progn + (push (substring string (car comp) (cadr comp)) result) + (setq start (cadr comp))) + (push (substring string start (1+ start)) result) + (setq start (1+ start)))) + (nreverse result))) (provide 'subr-x) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 0ae355e5917..8f6c655dbef 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -115,16 +115,25 @@ where: This should be either a function, or a list. If a list, each element has the form (ID [DESC1 ... DESCN]), where: + - ID is nil, or a Lisp object uniquely identifying this entry, which is used to keep the cursor on the \"same\" entry when rearranging the list. Comparison is done with `equal'. - Each DESC is a column descriptor, one for each column - specified in `tabulated-list-format'. A descriptor is either - a string, which is printed as-is, or a list (LABEL . PROPS), - which means to use `insert-text-button' to insert a text - button with label LABEL and button properties PROPS. - The string, or button label, must not contain any newline. + specified in `tabulated-list-format'. The descriptor DESC is + one of: + + - A string, which is printed as-is, and must not contain any + newlines. + + - An image descriptor (a list), which is used to insert an + image (see Info node `(elisp) Image Descriptors'). + + - A list (LABEL . PROPS), which means to use + `insert-text-button' to insert a text button with label + LABEL and button properties PROPS. LABEL must not contain + any newlines. If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") @@ -547,7 +556,9 @@ Return the column number after insertion." (props (nthcdr 3 format)) (pad-right (or (plist-get props :pad-right) 1)) (right-align (plist-get props :right-align)) - (label (if (stringp col-desc) col-desc (car col-desc))) + (label (cond ((stringp col-desc) col-desc) + ((eq (car col-desc) 'image) " ") + (t (car col-desc)))) (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) @@ -571,11 +582,15 @@ Return the column number after insertion." 'display `(space :align-to ,(+ x shift)))) (setq width (- width shift)) (setq x (+ x shift)))) - (if (stringp col-desc) - (insert (if (get-text-property 0 'help-echo label) - label - (propertize label 'help-echo help-echo))) - (apply 'insert-text-button label (cdr col-desc))) + (cond ((stringp col-desc) + (insert (if (get-text-property 0 'help-echo label) + label + (propertize label 'help-echo help-echo)))) + ((eq (car col-desc) 'image) + (insert (propertize " " + 'display col-desc + 'help-echo help-echo))) + ((apply 'insert-text-button label (cdr col-desc)))) (let ((next-x (+ x pad-right width))) ;; No need to append any spaces if this is the last column. (when not-last-col |