summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/byte-opt.el66
-rw-r--r--lisp/emacs-lisp/byte-run.el6
-rw-r--r--lisp/emacs-lisp/bytecomp.el3
-rw-r--r--lisp/emacs-lisp/cconv.el7
-rw-r--r--lisp/emacs-lisp/cl-generic.el21
-rw-r--r--lisp/emacs-lisp/debug.el6
-rw-r--r--lisp/emacs-lisp/derived.el7
-rw-r--r--lisp/emacs-lisp/easy-mmode.el3
-rw-r--r--lisp/emacs-lisp/edebug.el6
-rw-r--r--lisp/emacs-lisp/eieio-compat.el4
-rw-r--r--lisp/emacs-lisp/eieio.el2
-rw-r--r--lisp/emacs-lisp/eldoc.el9
-rw-r--r--lisp/emacs-lisp/elp.el13
-rw-r--r--lisp/emacs-lisp/ert-x.el22
-rw-r--r--lisp/emacs-lisp/ert.el130
-rw-r--r--lisp/emacs-lisp/lisp-mode.el84
-rw-r--r--lisp/emacs-lisp/memory-report.el3
-rw-r--r--lisp/emacs-lisp/package.el22
-rw-r--r--lisp/emacs-lisp/shortdoc.el10
-rw-r--r--lisp/emacs-lisp/subr-x.el50
20 files changed, 399 insertions, 75 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index c8990f23531..9b3b2e5ce14 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,
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/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 4834fb13c6a..2c292415cfe 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -100,6 +100,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 +590,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 +636,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
@@ -691,7 +686,7 @@ for all those different tags in the method-cache.")
;; 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 +1138,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/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 [&not keywordp] sexp
&optional [&not 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.el b/lisp/emacs-lisp/eieio.el
index 2dc3e0aeffa..3d73e5fef7b 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))
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..a492ef5093f 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -368,17 +368,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.
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index b7d984374cb..efc1825017b 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.
@@ -218,11 +219,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
@@ -779,7 +776,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,6 +2663,126 @@ 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 value) specs))
+ (forward-line 1)))
+ (nreverse specs))))
+
(defvar ert-unload-hook ())
(add-hook 'ert-unload-hook #'ert--unload-function)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index bb00a97f8e3..15afdef0252 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,52 @@ 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))))))
+ (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 +1188,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 +1211,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 +1286,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..cda2dee6cbc 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)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 5445fa970f8..fcbcdc79d8e 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!"))
@@ -2487,6 +2488,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'."
@@ -2713,6 +2723,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))))
@@ -2758,6 +2771,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
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 17ac3e471c0..817dfa6b71e 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))
@@ -241,7 +242,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
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 788cd0f34bf..9a82fe2449d 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,52 @@ 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's LINES number of empty lines before point.
+If LINES is nil or missing, a this ensures that there's a single
+empty line before point.
+
+Interactively, this command uses the numerical prefix for LINES.
+
+If there's already more empty lines before point than LINES, the
+number of blank lines will be reduced.
+
+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)))))
(provide 'subr-x)
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-24 16:50:20 +0000