diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/backtrace.el | 24 | ||||
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 66 | ||||
| -rw-r--r-- | lisp/emacs-lisp/byte-run.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 11 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eldoc.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 91 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/map-ynp.el | 12 | ||||
| -rw-r--r-- | lisp/emacs-lisp/re-builder.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/shortdoc.el | 42 | ||||
| -rw-r--r-- | lisp/emacs-lisp/subr-x.el | 52 |
11 files changed, 187 insertions, 119 deletions
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index a5721aa3193..a8b484aee0b 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -55,9 +55,9 @@ order to debug the code that does fontification." (defcustom backtrace-line-length 5000 "Target length for lines in Backtrace buffers. Backtrace mode will attempt to abbreviate printing of backtrace -frames to make them shorter than this, but success is not -guaranteed. If set to nil or zero, Backtrace mode will not -abbreviate the forms it prints." +frames by setting `print-level' and `print-length' to make them +shorter than this, but success is not guaranteed. If set to nil +or zero, backtrace mode will not abbreviate the forms it prints." :type 'integer :group 'backtrace :version "27.1") @@ -751,6 +751,13 @@ property for use by navigation." (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) (put-text-property beg (point) 'backtrace-section 'func))) +(defun backtrace--line-length-or-nil () + "Return `backtrace-line-length' if valid, nil else." + ;; mirror the logic in `cl-print-to-string-with-limits' + (and (natnump backtrace-line-length) + (not (zerop backtrace-line-length)) + backtrace-line-length)) + (defun backtrace--print-func-and-args (frame _view) "Print the function, arguments and buffer position of a backtrace FRAME. Format it according to VIEW." @@ -769,11 +776,16 @@ Format it according to VIEW." (if (atom fun) (funcall backtrace-print-function fun) (insert - (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) + (backtrace--print-to-string + fun + (when (and args (backtrace--line-length-or-nil)) + (/ backtrace-line-length 2))))) (if args (insert (backtrace--print-to-string - args (max (truncate (/ backtrace-line-length 5)) - (- backtrace-line-length (- (point) beg))))) + args + (if (backtrace--line-length-or-nil) + (max (truncate (/ backtrace-line-length 5)) + (- backtrace-line-length (- (point) beg)))))) ;; The backtrace-form property is so that backtrace-multi-line ;; will find it. backtrace-multi-line doesn't do anything ;; useful with it, just being consistent. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 9c64083b64b..f6db803b78e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1186,72 +1186,6 @@ 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 d82d9454e84..2ce2efd2aa7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -134,6 +134,7 @@ The return value of this function is not used." :autoload-end (eval-and-compile (defun ,cfname (,@(car data) ,@args) + (ignore ,@(delq '&rest (delq '&optional (copy-sequence args)))) ,@(cdr data)))))))) (defalias 'byte-run--set-doc-string diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 471a0b623ad..5ce5b2952b8 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1672,9 +1672,14 @@ URLs." ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. (replace-regexp-in-string - (rx "\\" (or (seq "[" (* (not "]")) "]"))) + (rx "\\[" (* (not "]")) "]") (make-string byte-compile--wide-docstring-substitution-len ?x) - docstring)))) + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (replace-regexp-in-string + (rx "\\`" (group (* (not "'"))) "'") + "\\1" + docstring))))) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. @@ -5043,6 +5048,8 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + ;;; tags diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index b30d3fc30f4..cd0e7dca7cf 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -385,7 +385,8 @@ Also store it in `eldoc-last-message' and return that value." ;; 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 + (and (boundp 'show-paren-context-when-offscreen) + show-paren-context-when-offscreen (not (pos-visible-in-window-p (overlay-end show-paren--overlay))))))) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 8ebc81fd418..946193e40dc 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -77,6 +77,35 @@ Use nil for no limit (caution: backtrace lines can be very long)." :type '(choice (const :tag "No truncation" nil) integer)) +(defvar ert-batch-print-length 10 + "`print-length' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-length' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-print-level 5 + "`print-level' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-level' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-backtrace-line-length t + "Target length for lines in ERT batch backtraces. + +Even modest settings for `print-length' and `print-level' can +produce extremely long lines in backtraces and lengthy delays in +forming them. This variable governs the target maximum line +length by manipulating these two variables while printing stack +traces. Setting this variable to t will re-use the value of +`backtrace-line-length' while printing stack traces in ERT batch +mode. Any other value will be temporarily bound to +`backtrace-line-length' when producing stack traces in batch +mode.") + (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) @@ -120,6 +149,10 @@ Use nil for no limit (caution: backtrace lines can be very long)." ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) + (when (and noninteractive (get symbol 'ert--test)) + ;; Make sure duplicated tests are discovered since the older test would + ;; be ignored silently otherwise. + (error "Test `%s' redefined" symbol)) (define-symbol-prop symbol 'ert--test definition) definition) @@ -175,6 +208,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" (declare (debug (&define [&name "test@" symbolp] @@ -1402,8 +1438,7 @@ Returns the stats object." (ert-reason-for-test-result result) "")))) (message "%s" ""))))) - (test-started - ) + (test-started) (test-ended (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) @@ -1413,8 +1448,14 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (insert (backtrace-to-string - (ert-test-result-with-condition-backtrace result))) + (let ((backtrace-line-length + (if (eq ert-batch-backtrace-line-length t) + backtrace-line-length + ert-batch-backtrace-line-length)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (insert (backtrace-to-string + (ert-test-result-with-condition-backtrace result)))) (if (not ert-batch-backtrace-right-margin) (message "%s" (buffer-substring-no-properties (point-min) @@ -1433,8 +1474,8 @@ Returns the stats object." (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) - (print-level 5) - (print-length 10)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) @@ -1962,13 +2003,13 @@ otherwise." (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) -(defun ert--setup-results-buffer (stats listener buffer-name) +(defvar ert--output-buffer-name "*ert*") + +(defun ert--setup-results-buffer (stats listener) "Set up a test results buffer. -STATS is the stats object; LISTENER is the results listener; -BUFFER-NAME, if non-nil, is the buffer name to use." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (get-buffer-create buffer-name))) +STATS is the stats object; LISTENER is the results listener." + (let ((buffer (get-buffer-create ert--output-buffer-name))) (with-current-buffer buffer (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2000,18 +2041,11 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (defvar ert--selector-history nil "List of recent test selectors read from terminal.") -;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? -;; They are needed only for our automated self-tests at the moment. -;; Or should there be some other mechanism? ;;;###autoload -(defun ert-run-tests-interactively (selector - &optional output-buffer-name message-fn) +(defun ert-run-tests-interactively (selector) "Run the tests specified by SELECTOR and display the results in a buffer. -SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message." +SELECTOR works as described in `ert-select-tests'." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is @@ -2022,25 +2056,18 @@ and how to display message." (read (completing-read (format-prompt "Run tests" default) obarray #'ert-test-boundp nil nil - 'ert--selector-history default nil))) - nil)) - (unless message-fn (setq message-fn 'message)) - (let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + 'ert--selector-history default nil))))) + (let (buffer listener) (setq listener (lambda (event-type &rest event-args) (cl-ecase event-type (run-started (cl-destructuring-bind (stats) event-args - (setq buffer (ert--setup-results-buffer stats - listener - output-buffer-name)) + (setq buffer (ert--setup-results-buffer stats listener)) (pop-to-buffer buffer))) (run-ended (cl-destructuring-bind (stats abortedp) event-args - (funcall message-fn + (message "%sRan %s tests, %s results were as expected%s%s" (if (not abortedp) "" @@ -2394,7 +2421,7 @@ To be used in the ERT results buffer." (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) - (ert-run-tests-interactively selector (buffer-name)))) + (ert-run-tests-interactively selector))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index d90d0f5f6ac..416d64558d9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1308,6 +1308,7 @@ Lisp function does not specify a special indentation." (put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) +(put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b95f11eab64..2f2f96ca0da 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -215,12 +215,12 @@ The function's value is the number of actions taken." (action (or (nth 2 help) "act on"))) (concat (format-message - "\ -Type SPC or `y' to %s the current %s; -DEL or `n' to skip the current %s; -RET or `q' to skip the current and all remaining %s; -C-g to quit (cancel the whole command); -! to %s all remaining %s;\n" + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s the current %s; +\\`DEL' or \\`n' to skip the current %s; +\\`RET' or \\`q' to skip the current and all remaining %s; +\\`C-g' to quit (cancel the whole command); +\\`!' to %s all remaining %s;\n") action object object objects action objects) (mapconcat (lambda (elt) (format "%s to %s;\n" diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index aec438ed994..5516b2a81f4 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -448,7 +448,8 @@ provided in the Commentary section of this library." (setq reb-subexp-mode t) (reb-update-modestring) (use-local-map reb-subexp-mode-map) - (message "`0'-`9' to display subexpressions `q' to quit subexp mode")) + (message (substitute-command-keys + "\\`0'-\\`9' to display subexpressions \\`q' to quit subexp mode"))) (defun reb-show-subexp (subexp &optional pause) "Visually show limit of subexpression SUBEXP of recent search. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index a9f548b104e..ba08e68af57 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -159,8 +159,6 @@ 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)) @@ -198,6 +196,13 @@ There can be any number of :example/:result elements." :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) (try-completion :eval (try-completion "foo" '("foobar" "foozot" "gazonk"))) + "Unicode Strings" + (string-glyph-split + :eval (string-glyph-split "Hello, πΌπ»π§πΌβπ€βπ§π»")) + (string-glyph-compose + :eval (string-glyph-compose "AΜ")) + (string-glyph-decompose + :eval (string-glyph-decompose "β«")) "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) @@ -1222,6 +1227,39 @@ There can be any number of :example/:result elements." (text-property-search-backward :no-eval (text-property-search-backward 'face nil t))) +(define-short-documentation-group keymaps + "Defining keymaps" + (define-keymap + :no-eval (define-keymap "C-c C-c" #'quit-buffer)) + (defvar-keymap + :no-eval (defvar-keymap my-keymap "C-c C-c" map #'quit-buffer)) + "Setting keys" + (keymap-set + :no-eval (keymap-set map "C-c C-c" #'quit-buffer)) + (keymap-local-set + :no-eval (keymap-local-set "C-c C-c" #'quit-buffer)) + (keymap-global-set + :no-eval (keymap-global-set "C-c C-c" #'quit-buffer)) + (keymap-unset + :no-eval (keymap-unset map "C-c C-c")) + (keymap-local-unset + :no-eval (keymap-local-unset "C-c C-c")) + (keymap-global-unset + :no-eval (keymap-global-unset "C-c C-c")) + (keymap-substitute + :no-eval (keymap-substitute map "C-c C-c" "M-a")) + (keymap-set-after + :no-eval (keymap-set-after map "<separator-2>" menu-bar-separator)) + "Predicates" + (keymapp + :eval (keymapp (define-keymap))) + (key-valid-p + :eval (key-valid-p "C-c C-c") + :eval (key-valid-p "C-cC-c")) + "Lookup" + (keymap-lookup + :eval (keymap-lookup (current-global-map) "C-x x g"))) + ;;;###autoload (defun shortdoc-display-group (group &optional function) "Pop to a buffer with short documentation summary for functions in GROUP. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index f336799040f..b53245b9b5f 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -446,8 +446,7 @@ is inserted before adjusting the number of empty lines." "Return the width of STRING in pixels." (with-temp-buffer (insert string) - (car (window-text-pixel-size - (current-buffer) (point-min) (point))))) + (car (buffer-text-pixel-size nil nil t)))) ;;;###autoload (defun string-glyph-split (string) @@ -457,7 +456,12 @@ This takes into account combining characters and grapheme clusters." (start 0) comp) (while (< start (length string)) - (if (setq comp (find-composition-internal start nil string nil)) + (if (setq comp (find-composition-internal + start + ;; Don't search backward in the string for the + ;; start of the composition. + (min (length string) (1+ start)) + string nil)) (progn (push (substring string (car comp) (cadr comp)) result) (setq start (cadr comp))) @@ -465,6 +469,48 @@ This takes into account combining characters and grapheme clusters." (setq start (1+ start)))) (nreverse result))) +;;;###autoload +(defun add-display-text-property (start end prop value + &optional object) + "Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer." + (let ((sub-start start) + (sub-end 0) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + (if (stringp object) + (min (length object) end) + (min end (point-max))))) + (if (not (setq disp (get-text-property sub-start 'display object))) + ;; No old properties in this range. + (put-text-property sub-start sub-end 'display (list prop value)) + ;; We have old properties. + (let ((vector nil)) + ;; Make disp into a list. + (setq disp + (cond + ((vectorp disp) + (setq vector t) + (seq-into disp 'list)) + ((not (consp (car disp))) + (list disp)) + (t + disp))) + ;; Remove any old instances. + (when-let ((old (assoc prop disp))) + (setq disp (delete old disp))) + (setq disp (cons (list prop value) disp)) + (when vector + (setq disp (seq-into disp 'vector))) + ;; Finally update the range. + (put-text-property sub-start sub-end 'display disp))) + (setq sub-start sub-end)))) + (provide 'subr-x) ;;; subr-x.el ends here |