From e0244f58042740c8fe914e7abe5b02611b176bc2 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Sat, 24 Jun 2023 17:16:19 +0300 Subject: [PATCH 1/8] ; * lisp/progmodes/project.el (project-current): Doc fix. Avoid saying that 'project-current' asks specifically for a directory, as it can also ask for a project's directory by other identifiers, such as the project's name, when 'project-prompter' is set to a different value than the default 'project-prompt-project-dir'. (Bug#64266) --- lisp/progmodes/project.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 1d5a5fa5c63..03ed966cc45 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -219,8 +219,10 @@ Called with no arguments and should return a project root dir." When no project is found in that directory, the result depends on the value of MAYBE-PROMPT: if it is nil or omitted, return nil, -else ask the user for a directory in which to look for the -project, and if no project is found there, return a \"transient\" +else prompt the user for the project to use. To prompt for a +project, call the function specified by `project-prompter', which +returns the directory in which to look for the project. If no +project is found in that directory, return a \"transient\" project instance. The \"transient\" project instance is a special kind of value From 587efce9faeb1a0b23b8367c02264a6f988832d0 Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Thu, 22 Jun 2023 16:59:19 +0200 Subject: [PATCH 2/8] Autodetect coding system when yanking media Some browers send eg 'text/html' selections formatted as UTF-8, but with a type of STRING, which actually means iso-latin-1. Autodetect the correct coding system to use by calling 'gui-get-selection'. * lisp/yank-media.el (yank-media--get-selection): Call 'gui-get-selection' instead of 'gui-backend-get-selection'. --- lisp/yank-media.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/yank-media.el b/lisp/yank-media.el index 3e33c1f9994..abc137d9c38 100644 --- a/lisp/yank-media.el +++ b/lisp/yank-media.el @@ -81,7 +81,7 @@ all the different selection types." (gui-get-selection 'CLIPBOARD 'TARGETS))) (defun yank-media--get-selection (data-type) - (when-let ((data (gui-backend-get-selection 'CLIPBOARD data-type))) + (when-let ((data (gui-get-selection 'CLIPBOARD data-type))) (if (string-match-p "\\`text/" (symbol-name data-type)) (yank-media-types--format data-type data) data))) From 488dc24d2a6ccbdd3f61c2d60629d2afd7a538d0 Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Mon, 19 Jun 2023 17:31:25 +0200 Subject: [PATCH 3/8] Prevent tex-shell buffer from reusing same window * lisp/window.el (display-tex-shell-buffer-action): Add 'inhibit-same-window' to the default action. --- lisp/window.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/window.el b/lisp/window.el index 424f1319ab7..d91bbabc010 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8795,7 +8795,8 @@ another window." :group 'windows :group 'comint) -(defcustom display-tex-shell-buffer-action '(display-buffer-in-previous-window) +(defcustom display-tex-shell-buffer-action '(display-buffer-in-previous-window + (inhibit-same-window . t)) "`display-buffer' action for displaying TeX shell buffers." :type display-buffer--action-custom-type :risky t From e5be6c7ae30933a77e81c88a05861dd575286c0c Mon Sep 17 00:00:00 2001 From: Spencer Baugh Date: Sun, 2 Jul 2023 17:49:23 -0400 Subject: [PATCH 4/8] Fix flymake mode line scrolling with pixel-scroll-precision-mode When pixel-scroll-precision-mode is enabled, scrolling the mouse wheel will yield wheel-{up,down} events. Flymake now binds the new events in addition to the old mouse-wheel-{up,down}-event. * lisp/progmodes/flymake.el:(flymake--mode-line-counter-scroll-prev) (flymake--mode-line-counter-scroll-next) flymake--mode-line-counter-map): New. (flymake--mode-line-counter): Use new keymap and include 'flymake--diagnostic-type' as a property in the mode-line. (Bug#64428) --- lisp/progmodes/flymake.el | 47 ++++++++++++++++++++++++++------------- 1 file changed, 32 insertions(+), 15 deletions(-) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 3f881ce0cf7..b4c0e4db6ac 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1568,6 +1568,36 @@ correctly.") (defun flymake--mode-line-counters () (when (flymake-running-backends) flymake-mode-line-counter-format)) +(defun flymake--mode-line-counter-scroll-prev (event) + (interactive "e") + (let* ((event-start (event-start event)) + (posn-string (posn-string event-start)) + (type (get-text-property + (cdr posn-string) 'flymake--diagnostic-type (car posn-string)))) + (with-selected-window (posn-window event-start) + (flymake-goto-prev-error 1 (list type) t)))) + +(defun flymake--mode-line-counter-scroll-next (event) + (interactive "e") + (let* ((event-start (event-start event)) + (posn-string (posn-string event-start)) + (type (get-text-property + (cdr posn-string) 'flymake--diagnostic-type (car posn-string)))) + (with-selected-window (posn-window event-start) + (flymake-goto-next-error 1 (list type) t)))) + +(defvar flymake--mode-line-counter-map + (let ((map (make-sparse-keymap))) + (define-key map (vector 'mode-line mouse-wheel-down-event) + #'flymake--mode-line-counter-scroll-prev) + (define-key map [mode-line wheel-down] + #'flymake--mode-line-counter-scroll-prev) + (define-key map (vector 'mode-line mouse-wheel-up-event) + #'flymake--mode-line-counter-scroll-next) + (define-key map [mode-line wheel-up] + #'flymake--mode-line-counter-scroll-next) + map)) + (defun flymake--mode-line-counter (type &optional no-space) "Compute number of diagnostics in buffer with TYPE's severity. TYPE is usually keyword `:error', `:warning' or `:note'." @@ -1598,21 +1628,8 @@ TYPE is usually keyword `:error', `:warning' or `:note'." ((eq type :warning) "warnings") ((eq type :note) "notes") (t (format "%s diagnostics" type)))) - keymap - ,(let ((map (make-sparse-keymap))) - (define-key map (vector 'mode-line - mouse-wheel-down-event) - (lambda (event) - (interactive "e") - (with-selected-window (posn-window (event-start event)) - (flymake-goto-prev-error 1 (list type) t)))) - (define-key map (vector 'mode-line - mouse-wheel-up-event) - (lambda (event) - (interactive "e") - (with-selected-window (posn-window (event-start event)) - (flymake-goto-next-error 1 (list type) t)))) - map)))))) + flymake--diagnostic-type ,type + keymap ,flymake--mode-line-counter-map))))) ;;; Per-buffer diagnostic listing From b94e7e6334718061879c32025941f00913078230 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 13 Jul 2023 19:38:36 +0300 Subject: [PATCH 5/8] * lisp/help-mode.el (help-setup-xref): Disable outline-minor-mode (bug#64575). --- lisp/help-mode.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index bf64d032b65..b51276d5e06 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -498,6 +498,10 @@ This should be called very early, before the output buffer is cleared, because we want to record the \"previous\" position of point so we can restore it properly when going back." (with-current-buffer (help-buffer) + ;; Disable `outline-minor-mode' in a reused Help buffer + ;; created by `describe-bindings' that enables this mode. + (when (bound-and-true-p outline-minor-mode) + (outline-minor-mode -1)) (when help-xref-stack-item (push (cons (point) help-xref-stack-item) help-xref-stack) (setq help-xref-forward-stack nil)) From 0cd519971d199836ba0a6e9f0e36af9b9accaf0d Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 13 Jul 2023 14:26:29 -0700 Subject: [PATCH 6/8] Port NaN, infinity handling better to VAX Nowadays .elc files routinely contain tokens like 1.0e+INF and 0.0e+NaN that do not work on antiques like the VAX that lack IEEE fp. Port Emacs to these platforms, by treating infinities as extreme values and NaNs as strings that trap if used numerically. * src/lread.c (INFINITY): Default to HUGE_VAL if non-IEEE. (not_a_number) [!IEEE_FLOATING_POINT]: New static array. (syms_of_lread) [!IEEE_FLOATING_POINT]: Initialize it. (read0): Report invalid syntax for +0.0e+NaN on platforms that lack NaNs. (string_to_number): On non-IEEE platforms, return HUGE_VAL for infinity and a string for NaN. All callers changed. --- doc/lispref/numbers.texi | 10 ++++++---- etc/NEWS | 8 ++++++++ src/data.c | 3 ++- src/lread.c | 29 ++++++++++++++++++++++++++--- src/process.c | 3 ++- 5 files changed, 44 insertions(+), 9 deletions(-) diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi index 3e45aa90fda..bcf89fc9ab1 100644 --- a/doc/lispref/numbers.texi +++ b/doc/lispref/numbers.texi @@ -270,10 +270,6 @@ two NaNs as equal when their signs and significands agree. Significands of NaNs are machine-dependent, as are the digits in their string representation. - NaNs are not available on systems which do not use IEEE -floating-point arithmetic; if the read syntax for a NaN is used on a -VAX, for example, the reader signals an error. - When NaNs and signed zeros are involved, non-numeric functions like @code{eql}, @code{equal}, @code{sxhash-eql}, @code{sxhash-equal} and @code{gethash} determine whether values are indistinguishable, not @@ -283,6 +279,12 @@ whether they are numerically equal. For example, when @var{x} and conversely, @code{(equal 0.0 -0.0)} returns @code{nil} whereas @code{(= 0.0 -0.0)} returns @code{t}. + Infinities and NaNs are not available on legacy systems that lack +IEEE floating-point arithmetic. On a circa 1980 VAX, for example, the +Lisp reader approximates an infinity with the nearest finite value, +and a NaN with some other non-numeric Lisp object that provokes an +error if used numerically. + Here are read syntaxes for these special floating-point values: @table @asis diff --git a/etc/NEWS b/etc/NEWS index 5d5ea990b92..997f7e82c2b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -585,6 +585,14 @@ behavior back for any other reason, you can do that using the previous behavior of showing 'U' in the mode line for 'koi8-u': (coding-system-put 'koi8-u :mnemonic ?U) + ++++ +** Infinities and NaNs no longer act as symbols on non-IEEE platforms. +On old platforms like the VAX that do not support IEEE floating-point, +tokens like 0.0e+NaN and 1.0e+INF are no longer read as symbols. +Instead, the Lisp reader approximates an infinity with the nearest +finite value, and a NaN with some other non-numeric object that +provokes an error if used numerically. * Lisp Changes in Emacs 30.1 diff --git a/src/data.c b/src/data.c index 6de8e0cf1a1..5a31462d8ca 100644 --- a/src/data.c +++ b/src/data.c @@ -3033,7 +3033,8 @@ If the base used is not 10, STRING is always parsed as an integer. */) p++; Lisp_Object val = string_to_number (p, b, 0); - return NILP (val) ? make_fixnum (0) : val; + return ((IEEE_FLOATING_POINT ? NILP (val) : !NUMBERP (val)) + ? make_fixnum (0) : val); } enum arithop diff --git a/src/lread.c b/src/lread.c index 51d0d2a3c24..6792ef27206 100644 --- a/src/lread.c +++ b/src/lread.c @@ -75,6 +75,10 @@ along with GNU Emacs. If not, see . */ # ifndef INFINITY # define INFINITY ((union ieee754_double) {.ieee = {.exponent = -1}}.d) # endif +#else +# ifndef INFINITY +# define INFINITY HUGE_VAL +# endif #endif /* The objects or placeholders read with the #n=object form. @@ -4477,10 +4481,17 @@ substitute_in_interval (INTERVAL interval, void *arg) } +#if !IEEE_FLOATING_POINT +/* Strings that stand in for +NaN, -NaN, respectively. */ +static Lisp_Object not_a_number[2]; +#endif + /* Convert the initial prefix of STRING to a number, assuming base BASE. If the prefix has floating point syntax and BASE is 10, return a nearest float; otherwise, if the prefix has integer syntax, return - the integer; otherwise, return nil. If PLEN, set *PLEN to the + the integer; otherwise, return nil. (On antique platforms that lack + support for NaNs, if the prefix has NaN syntax return a Lisp object that + will provoke an error if used as a number.) If PLEN, set *PLEN to the length of the numeric prefix if there is one, otherwise *PLEN is unspecified. */ @@ -4545,7 +4556,6 @@ string_to_number (char const *string, int base, ptrdiff_t *plen) cp++; while ('0' <= *cp && *cp <= '9'); } -#if IEEE_FLOATING_POINT else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F') { @@ -4558,12 +4568,17 @@ string_to_number (char const *string, int base, ptrdiff_t *plen) { state |= E_EXP; cp += 3; +#if IEEE_FLOATING_POINT union ieee754_double u = { .ieee_nan = { .exponent = 0x7ff, .quiet_nan = 1, .mantissa0 = n >> 31 >> 1, .mantissa1 = n }}; value = u.d; - } +#else + if (plen) + *plen = cp - string; + return not_a_number[negative]; #endif + } else cp = ecp; } @@ -5707,6 +5722,14 @@ that are loaded before your customizations are read! */); DEFSYM (Qcomma, ","); DEFSYM (Qcomma_at, ",@"); +#if !IEEE_FLOATING_POINT + for (int negative = 0; negative < 2; negative++) + { + not_a_number[negative] = build_pure_c_string (&"-0.0e+NaN"[!negative]); + staticpro (¬_a_number[negative]); + } +#endif + DEFSYM (Qinhibit_file_name_operation, "inhibit-file-name-operation"); DEFSYM (Qascii_character, "ascii-character"); DEFSYM (Qfunction, "function"); diff --git a/src/process.c b/src/process.c index 67d1d3e425f..2d6e08f16b5 100644 --- a/src/process.c +++ b/src/process.c @@ -7130,7 +7130,8 @@ See function `signal-process' for more details on usage. */) { ptrdiff_t len; tem = string_to_number (SSDATA (process), 10, &len); - if (NILP (tem) || len != SBYTES (process)) + if ((IEEE_FLOATING_POINT ? NILP (tem) : !NUMBERP (tem)) + || len != SBYTES (process)) return Qnil; } process = tem; From ee4cc106b88879c86d08c6fcda06657fb15df0f1 Mon Sep 17 00:00:00 2001 From: Spencer Baugh Date: Sun, 9 Jul 2023 10:24:33 -0400 Subject: [PATCH 7/8] Don't recalculate the buffer basename inside uniquify Previously, uniquify--create-file-buffer-advice would use the filename of the buffer to calculate what the buffer's basename should be. Now that gets passed in from create-file-buffer, which lets us fix several bugs: 1. before this patch, if a buffer happened to be named the same thing as directory in its default-directory, the buffer would get renamed with a directory separator according to uniquify-trailing-separator-p. 2. buffers with a leading space should get a leading |, as described by create-file-buffer's docstring; before this patch, uniquify would remove that leading |. * lisp/dired.el (dired-internal-noselect): Pass a directory name to create-file-buffer. * lisp/files.el (create-file-buffer): Do uniquify-trailing-separator-p handling if passed a directory filename. (bug#62732) * lisp/uniquify.el (uniquify-item): (uniquify-rationalize-file-buffer-names, uniquify-rationalize, uniquify-get-proposed-name, uniquify-rationalize-conflicting-sublist): Remove uniquify-trailing-separator-p handling. (uniquify--create-file-buffer-advice): Take new basename argument and use it, instead of recalculating the basename from the filename. --- lisp/dired.el | 2 +- lisp/files.el | 26 +++++--- lisp/uniquify.el | 39 ++++------- test/lisp/uniquify-tests.el | 129 ++++++++++++++++++++++++++++++++++++ 4 files changed, 159 insertions(+), 37 deletions(-) create mode 100644 test/lisp/uniquify-tests.el diff --git a/lisp/dired.el b/lisp/dired.el index 44df4621d6f..90342069154 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1311,7 +1311,7 @@ The return value is the target column for the file names." ;; Note that buffer already is in dired-mode, if found. (new-buffer-p (null buffer))) (or buffer - (setq buffer (create-file-buffer (directory-file-name dirname)))) + (setq buffer (create-file-buffer dirname))) (set-buffer buffer) (if (not new-buffer-p) ; existing buffer ... (cond (switches ; ... but new switches diff --git a/lisp/files.el b/lisp/files.el index 377ed1b8a0b..4b65ff10b68 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2084,22 +2084,30 @@ killed." (kill-buffer obuf)))))) ;; FIXME we really need to fold the uniquify stuff in here by default, -;; not using advice, and add it to the doc string. (defun create-file-buffer (filename) "Create a suitably named buffer for visiting FILENAME, and return it. FILENAME (sans directory) is used unchanged if that name is free; -otherwise a string <2> or <3> or ... is appended to get an unused name. +otherwise the buffer is renamed according to +`uniquify-buffer-name-style' to get an unused name. Emacs treats buffers whose names begin with a space as internal buffers. To avoid confusion when visiting a file whose name begins with a space, this function prepends a \"|\" to the final result if necessary." - (let* ((lastname (file-name-nondirectory filename)) - (lastname (if (string= lastname "") - filename lastname)) - (buf (generate-new-buffer (if (string-prefix-p " " lastname) - (concat "|" lastname) - lastname)))) - (uniquify--create-file-buffer-advice buf filename) + (let* ((lastname (file-name-nondirectory (directory-file-name filename))) + (lastname (cond + ((not (and uniquify-trailing-separator-p + (file-directory-p filename))) + lastname) + ((eq uniquify-buffer-name-style 'forward) + (file-name-as-directory lastname)) + ((eq uniquify-buffer-name-style 'reverse) + (concat (or uniquify-separator "\\") lastname)) + (t lastname))) + (basename (if (string-prefix-p " " lastname) + (concat "|" lastname) + lastname)) + (buf (generate-new-buffer basename))) + (uniquify--create-file-buffer-advice buf filename basename) buf)) (defvar abbreviated-home-dir nil diff --git a/lisp/uniquify.el b/lisp/uniquify.el index dee9ecba2ea..d1ca455b673 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -174,8 +174,8 @@ contains the name of the directory which the buffer is visiting.") (cl-defstruct (uniquify-item (:constructor nil) (:copier nil) (:constructor uniquify-make-item - (base dirname buffer &optional proposed original-dirname))) - base dirname buffer proposed original-dirname) + (base dirname buffer &optional proposed))) + base dirname buffer proposed) ;; Internal variables used free (defvar uniquify-possibly-resolvable nil) @@ -211,7 +211,7 @@ this rationalization." (when dirname (setq dirname (expand-file-name (directory-file-name dirname))) (let ((fix-list (list (uniquify-make-item base dirname newbuf - nil dirname))) + nil))) items) (dolist (buffer (buffer-list)) (when (and (not (and uniquify-ignore-buffers-re @@ -292,8 +292,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." (setf (uniquify-item-proposed item) (uniquify-get-proposed-name (uniquify-item-base item) (uniquify-item-dirname item) - nil - (uniquify-item-original-dirname item))) + nil)) (setq uniquify-managed fix-list))) ;; Strip any shared last directory names of the dirname. (when (and (cdr fix-list) uniquify-strip-common-suffix) @@ -316,8 +315,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." (uniquify-item-dirname item)))) (and f (directory-file-name f))) (uniquify-item-buffer item) - (uniquify-item-proposed item) - (uniquify-item-original-dirname item)) + (uniquify-item-proposed item)) fix-list))))) ;; If uniquify-min-dir-content is 0, this will end up just ;; passing fix-list to uniquify-rationalize-conflicting-sublist. @@ -345,21 +343,10 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." (uniquify-rationalize-conflicting-sublist conflicting-sublist old-proposed depth))) -(defun uniquify-get-proposed-name (base dirname &optional depth - original-dirname) +(defun uniquify-get-proposed-name (base dirname &optional depth) (unless depth (setq depth uniquify-min-dir-content)) (cl-assert (equal (directory-file-name dirname) dirname)) ;No trailing slash. - ;; Distinguish directories by adding extra separator. - (if (and uniquify-trailing-separator-p - (file-directory-p (expand-file-name base original-dirname)) - (not (string-equal base ""))) - (cond ((eq uniquify-buffer-name-style 'forward) - (setq base (file-name-as-directory base))) - ;; (setq base (concat base "/"))) - ((eq uniquify-buffer-name-style 'reverse) - (setq base (concat (or uniquify-separator "\\") base))))) - (let ((extra-string nil) (n depth)) (while (and (> n 0) dirname) @@ -421,8 +408,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." (uniquify-get-proposed-name (uniquify-item-base item) (uniquify-item-dirname item) - depth - (uniquify-item-original-dirname item)))) + depth))) (uniquify-rationalize-a-list conf-list depth)) (unless (string= old-name "") (uniquify-rename-buffer (car conf-list) old-name))))) @@ -492,15 +478,14 @@ For use on `kill-buffer-hook'." ;; (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) -(defun uniquify--create-file-buffer-advice (buf filename) +(defun uniquify--create-file-buffer-advice (buf filename basename) ;; BEWARE: This is called directly from `files.el'! "Uniquify buffer names with parts of directory name." (when uniquify-buffer-name-style - (let ((filename (expand-file-name (directory-file-name filename)))) - (uniquify-rationalize-file-buffer-names - (file-name-nondirectory filename) - (file-name-directory filename) - buf)))) + (uniquify-rationalize-file-buffer-names + basename + (file-name-directory (expand-file-name (directory-file-name filename))) + buf))) (defun uniquify-unload-function () "Unload the uniquify library." diff --git a/test/lisp/uniquify-tests.el b/test/lisp/uniquify-tests.el new file mode 100644 index 00000000000..abd61fa3504 --- /dev/null +++ b/test/lisp/uniquify-tests.el @@ -0,0 +1,129 @@ +;;; uniquify-tests.el --- Tests for uniquify -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Spencer Baugh + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest uniquify-basic () + (let (bufs old-names) + (cl-flet ((names-are (current-names &optional nosave) + (should (equal (mapcar #'buffer-name bufs) current-names)) + (unless nosave (push current-names old-names)))) + (should (eq (get-buffer "z") nil)) + (push (find-file-noselect "a/b/z") bufs) + (names-are '("z")) + (push (find-file-noselect "a/b/c/z") bufs) + (names-are '("z" "z")) + (push (find-file-noselect "a/b/d/z") bufs) + (names-are '("z" "z" "z")) + (push (find-file-noselect "e/b/z") bufs) + (names-are '("z" "z" "z" "z")) + ;; buffers without a buffer-file-name don't get uniquified by uniquify + (push (generate-new-buffer "z") bufs) + (names-are '("z" "z" "z" "z" "z")) + ;; but they do get uniquified by the C code which uses + (push (generate-new-buffer "z") bufs) + (names-are '("z<2>" "z" "z" "z" "z" "z")) + (save-excursion + ;; uniquify will happily work with file-visiting buffers whose names don't match buffer-file-name + (find-file "f/y") + (push (current-buffer) bufs) + (rename-buffer "z" t) + (names-are '("z" "z<2>" "z" "z" "z" "z" "z") 'nosave) + ;; somewhat confusing behavior results if a buffer is renamed to match an already-uniquified buffer + (rename-buffer "z" t) + (names-are '("z" "z<2>" "z" "z" "z" "z" "z") 'nosave)) + (while bufs + (kill-buffer (pop bufs)) + (names-are (pop old-names) 'nosave))))) + +(ert-deftest uniquify-dirs () + "Check strip-common-suffix and trailing-separator-p work together; bug#47132" + (let* ((root (make-temp-file "emacs-uniquify-tests" 'dir)) + (a-path (file-name-concat root "a/x/y/dir")) + (b-path (file-name-concat root "b/x/y/dir"))) + (make-directory a-path 'parents) + (make-directory b-path 'parents) + (let ((uniquify-buffer-name-style 'forward) + (uniquify-strip-common-suffix t) + (uniquify-trailing-separator-p nil)) + (let ((bufs (list (find-file-noselect a-path) + (find-file-noselect b-path)))) + (should (equal (mapcar #'buffer-name bufs) + '("a/dir" "b/dir"))) + (mapc #'kill-buffer bufs))) + (let ((uniquify-buffer-name-style 'forward) + (uniquify-strip-common-suffix nil) + (uniquify-trailing-separator-p t)) + (let ((bufs (list (find-file-noselect a-path) + (find-file-noselect b-path)))) + (should (equal (mapcar #'buffer-name bufs) + '("a/x/y/dir/" "b/x/y/dir/"))) + (mapc #'kill-buffer bufs))) + (let ((uniquify-buffer-name-style 'forward) + (uniquify-strip-common-suffix t) + (uniquify-trailing-separator-p t)) + (let ((bufs (list (find-file-noselect a-path) + (find-file-noselect b-path)))) + (should (equal (mapcar #'buffer-name bufs) + '("a/dir/" "b/dir/"))) + (mapc #'kill-buffer bufs))))) + +(ert-deftest uniquify-rename-to-dir () + "Giving a buffer a name which matches a directory doesn't rename the buffer" + (let ((uniquify-buffer-name-style 'forward) + (uniquify-trailing-separator-p t)) + (save-excursion + (find-file "../README") + (rename-buffer "lisp" t) + (should (equal (buffer-name) "lisp")) + (kill-buffer)))) + +(ert-deftest uniquify-separator-style-reverse () + (let ((uniquify-buffer-name-style 'reverse) + (uniquify-trailing-separator-p t)) + (save-excursion + (should (file-directory-p "../lib-src")) + (find-file "../lib-src") + (should (equal (buffer-name) "\\lib-src")) + (kill-buffer)))) + +(ert-deftest uniquify-separator-ignored () + "If uniquify-buffer-name-style isn't forward or reverse, +uniquify-trailing-separator-p is ignored" + (let ((uniquify-buffer-name-style 'post-forward-angle-brackets) + (uniquify-trailing-separator-p t)) + (save-excursion + (should (file-directory-p "../lib-src")) + (find-file "../lib-src") + (should (equal (buffer-name) "lib-src")) + (kill-buffer)))) + +(ert-deftest uniquify-space-prefix () + "If a buffer starts with a space, | is added at the start" + (save-excursion + (find-file " foo") + (should (equal (buffer-name) "| foo")) + (kill-buffer))) + +(provide 'uniquify-tests) +;;; uniquify-tests.el ends here From 3ffb99f28f29cd98094f359ea316468572535aa0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 13 Jul 2023 19:00:51 -0400 Subject: [PATCH 8/8] cl-print: Put buttons on ellipses Currently, in *Backtrace* we have a nice behavior for cl-printed objects where they're truncated by default to a manageable size but we can click on the "..." to expand them when needed. The patch below moves that functionality to `cl-print.el` such that it can be enjoyed "everywhere" (bug#64536). It also has the benefit of simplifying the code since `backtrace.el` had to look for ellipses in order to add buttons to them, whereas now we can put the ellipses right when we write them. * lisp/emacs-lisp/cl-print.el (cl-print-object-contents): Improve docstring. (cl-print-expand-ellipsis-function): New var. (cl-print--default-expand-ellipsis): New function. (cl-print-expand-ellipsis): New command. (cl-print-insert-ellipsis): Allow nil instead of 0 to mean "this elides the whole object". (cl-print-ellipsis): Move button type from `backtrace.el`. (cl-print-propertize-ellipsis): Put a button. (cl-print--expand-ellipsis): Rename from `cl-print-expand-ellipsis`. (cl-print-to-string-with-limit): Allow new value t for `limit`. * lisp/emacs-lisp/backtrace.el (backtrace--font-lock-keywords): Simplify. (backtrace--match-ellipsis-in-string): Delete function. (backtrace--change-button-skip): Adjust to new button type name. (backtrace--expand-ellipsis): New function, extracted from `backtrace-expand-ellipsis`. (backtrace-expand-ellipsis): Delete function. (backtrace-ellipsis): Move button type to `cl-print.el`. (backtrace--print-to-string): Don't look for cl-print ellipses any more. (backtrace-mode): Use `backtrace--expand-ellipsis`. * lisp/ielm.el (ielm--expand-ellipsis): New function. (inferior-emacs-lisp-mode): Use it to fill the data when expanded. * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-check-ellipsis-expansion) (cl-print-tests-check-ellipsis-expansion-rx): Adjust to new internal function name. --- etc/NEWS | 4 + etc/NEWS.26 | 2 +- lisp/button.el | 2 +- lisp/emacs-lisp/backtrace.el | 67 +++------------- lisp/emacs-lisp/cl-print.el | 104 +++++++++++++++++++------ lisp/ielm.el | 7 ++ test/lisp/emacs-lisp/cl-print-tests.el | 5 +- 7 files changed, 108 insertions(+), 83 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 997f7e82c2b..3e56fbb973c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -92,6 +92,10 @@ plus, minus, check-mark, start, etc. The 'tool-bar-position' frame parameter can be set to 'bottom' on all window systems other than Nextstep. +** You can expand the "..." truncation everywhere. +The code that allowed "..." to be expanded in the *Backtrace* should +now work anywhere the data is generated by `cl-print`. + ** Modeline elements can now be right-aligned. Anything following the symbol 'mode-line-format-right-align' in 'mode-line-format' will be right-aligned. Exactly where it is diff --git a/etc/NEWS.26 b/etc/NEWS.26 index 1692e23483c..29eee5eb4a2 100644 --- a/etc/NEWS.26 +++ b/etc/NEWS.26 @@ -1927,6 +1927,6 @@ along with GNU Emacs. If not, see . Local variables: coding: utf-8 -mode: outline +mode: emacs-news paragraph-separate: "[ ]*$" end: diff --git a/lisp/button.el b/lisp/button.el index f043073ea86..002064fbea0 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -123,7 +123,7 @@ argument). In addition, the keyword argument :supertype may be used to specify a `button-type' from which NAME inherits its default property values -(however, the inheritance happens only when NAME is defined; subsequent +\(however, the inheritance happens only when NAME is defined; subsequent changes to a supertype are not reflected in its subtypes)." (declare (indent defun)) (let ((catsym (make-symbol (concat (symbol-name name) "-button"))) diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 57912c854b0..af06577fe56 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -135,8 +135,7 @@ frames before its nearest activation frame are discarded." ;; Font Locking support (defconst backtrace--font-lock-keywords - '((backtrace--match-ellipsis-in-string - (1 'button prepend))) + '() "Expressions to fontify in Backtrace mode. Fontify these in addition to the expressions Emacs Lisp mode fontifies.") @@ -154,16 +153,6 @@ fontifies.") backtrace--font-lock-keywords) "Gaudy level highlighting for Backtrace mode.") -(defun backtrace--match-ellipsis-in-string (bound) - ;; Fontify ellipses within strings as buttons. - ;; This is necessary because ellipses are text property buttons - ;; instead of overlay buttons, which is done because there could - ;; be a large number of them. - (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t) - (and (get-text-property (- (point) 2) 'cl-print-ellipsis) - (get-text-property (- (point) 3) 'cl-print-ellipsis) - (get-text-property (- (point) 4) 'cl-print-ellipsis)))) - ;;; Xref support (defun backtrace--xref-backend () 'elisp) @@ -425,11 +414,11 @@ the buffer." (defun backtrace--change-button-skip (beg end value) "Change the skip property on all buttons between BEG and END. -Set it to VALUE unless the button is a `backtrace-ellipsis' button." +Set it to VALUE unless the button is a `cl-print-ellipsis' button." (let ((inhibit-read-only t)) (setq beg (next-button beg)) (while (and beg (< beg end)) - (unless (eq (button-type beg) 'backtrace-ellipsis) + (unless (eq (button-type beg) cl-print-ellipsis) (button-put beg 'skip value)) (setq beg (next-button beg))))) @@ -497,33 +486,15 @@ Reprint the frame with the new view plist." `(backtrace-index ,index backtrace-view ,view)) (goto-char min))) -(defun backtrace-expand-ellipsis (button) - "Expand display of the elided form at BUTTON." - (goto-char (button-start button)) - (unless (get-text-property (point) 'cl-print-ellipsis) - (if (and (> (point) (point-min)) - (get-text-property (1- (point)) 'cl-print-ellipsis)) - (backward-char) - (user-error "No ellipsis to expand here"))) - (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) - (begin (previous-single-property-change end 'cl-print-ellipsis)) - (value (get-text-property begin 'cl-print-ellipsis)) - (props (backtrace-get-text-properties begin)) +(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args) + "Wrapper to expand an ellipsis. +For use on `cl-print-expand-ellipsis-function'." + (let* ((props (backtrace-get-text-properties begin)) (inhibit-read-only t)) (backtrace--with-output-variables (backtrace-get-view) - (delete-region begin end) - (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value - backtrace-line-length)) - (setq end (point)) - (goto-char begin) - (while (< (point) end) - (let ((next (next-single-property-change (point) 'cl-print-ellipsis - nil end))) - (when (get-text-property (point) 'cl-print-ellipsis) - (make-text-button (point) next :type 'backtrace-ellipsis)) - (goto-char next))) - (goto-char begin) - (add-text-properties begin end props)))) + (let ((end (apply orig-fun begin end val backtrace-line-length args))) + (add-text-properties begin end props) + end)))) (defun backtrace-expand-ellipses (&optional no-limit) "Expand display of all \"...\"s in the backtrace frame at point. @@ -696,13 +667,6 @@ line and recenter window line accordingly." (recenter window-line))) (goto-char (point-min))))) -;; Define button type used for ...'s. -;; Set skip property so you don't have to TAB through 100 of them to -;; get to the next function name. -(define-button-type 'backtrace-ellipsis - 'skip t 'action #'backtrace-expand-ellipsis - 'help-echo "mouse-2, RET: expand this ellipsis") - (defun backtrace-print-to-string (obj &optional limit) "Return a printed representation of OBJ formatted for backtraces. Attempt to get the length of the returned string under LIMIT @@ -719,15 +683,6 @@ characters with appropriate settings of `print-level' and (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit)) ;; Add a unique backtrace-form property. (put-text-property (point-min) (point) 'backtrace-form (gensym)) - ;; Make buttons from all the "..."s. Since there might be many of - ;; them, use text property buttons. - (goto-char (point-min)) - (while (< (point) (point-max)) - (let ((end (next-single-property-change (point) 'cl-print-ellipsis - nil (point-max)))) - (when (get-text-property (point) 'cl-print-ellipsis) - (make-text-button (point) end :type 'backtrace-ellipsis)) - (goto-char end))) (buffer-string))) (defun backtrace-print-frame (frame view) @@ -918,6 +873,8 @@ followed by `backtrace-print-frame', once for each stack frame." (setq-local filter-buffer-substring-function #'backtrace--filter-visible) (setq-local indent-line-function 'lisp-indent-line) (setq-local indent-region-function 'lisp-indent-region) + (add-function :around (local 'cl-print-expand-ellipsis-function) + #'backtrace--expand-ellipsis) (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t)) (put 'backtrace-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 9578d556421..905c2bc9f09 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -54,9 +54,12 @@ call other entry points instead, such as `cl-prin1'." (prin1 object stream)) (cl-defgeneric cl-print-object-contents (_object _start _stream) - "Dispatcher to print the contents of OBJECT on STREAM. -Print the contents starting with the item at START, without -delimiters." + "Dispatcher to print partial contents of OBJECT on STREAM. +This is used when replacing an ellipsis with the contents it +represents. OBJECT is the object that has been partially printed +and START represents the place at which the contents where +replaced with an ellipsis. +Print the contents hidden by the ellipsis to STREAM." ;; Every cl-print-object method which can print an ellipsis should ;; have a matching cl-print-object-contents method to expand an ;; ellipsis. @@ -65,7 +68,7 @@ delimiters." (cl-defmethod cl-print-object ((object cons) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) (let ((car (pop object))) (if (and print-quoted (memq car '(\, quote function \` \,@ \,.)) @@ -107,7 +110,7 @@ delimiters." (cl-defmethod cl-print-object ((object vector) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) (princ "[" stream) (cl-print--vector-contents object 0 stream) (princ "]" stream))) @@ -129,6 +132,8 @@ delimiters." (cl-print--vector-contents object start stream)) ;FIXME: η-redex! (cl-defmethod cl-print-object ((object hash-table) stream) + ;; FIXME: Make it possible to see the contents, like `prin1' does, + ;; e.g. using ellipsis. Make sure `cl-fill' can pretty print the result! (princ "#" so that pp.el gives better results. @@ -212,7 +220,7 @@ into a button whose action shows the function's disassembly.") (cl-defmethod cl-print-object ((object cl-structure-object) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) (princ "#s(" stream) (princ (cl--struct-class-name (cl-find-class (type-of object))) stream) (cl-print--struct-contents object 0 stream) @@ -250,7 +258,7 @@ into a button whose action shows the function's disassembly.") cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) ;; Print all or part of the string (when has-properties (princ "#(" stream)) @@ -325,6 +333,7 @@ into a button whose action shows the function's disassembly.") (cl-defmethod cl-print-object :around (object stream) ;; FIXME: Only put such an :around method on types where it's relevant. (let ((cl-print--depth (if cl-print--depth (1+ cl-print--depth) 1))) + ;; FIXME: Handle print-level here once and forall? (cond (print-circle (let ((n (gethash object cl-print--number-table))) @@ -401,10 +410,53 @@ into a button whose action shows the function's disassembly.") (cl-print--find-sharing object print-number-table))) print-number-table)) +(define-button-type 'cl-print-ellipsis + 'skip t 'action #'cl-print-expand-ellipsis + 'help-echo "mouse-2, RET: expand this ellipsis") + +(defvar cl-print-expand-ellipsis-function + #'cl-print--default-expand-ellipsis + "Function to tweak the way ellipses are expanded. +The function is called with 3 arguments, BEG, END, and FUNC. +BEG and END delimit the ellipsis that will be replaced. +FUNC is the function that will do the expansion. +It should be called with a single argument specifying the desired +limit of the expansion's length, as used in `cl-print-to-string-with-limit'. +FUNC will return the position of the end of the newly printed text.") + +(defun cl-print--default-expand-ellipsis (begin end value line-length) + (delete-region begin end) + (insert (cl-print-to-string-with-limit + #'cl-print--expand-ellipsis value line-length)) + (point)) + + +(defun cl-print-expand-ellipsis (&optional button) + "Expand display of the elided form at BUTTON. +BUTTON can also be a buffer position or nil (to mean point)." + (interactive) + (goto-char (cond + ((null button) (point)) + (t (button-start button)))) + (unless (get-text-property (point) 'cl-print-ellipsis) + (if (and (> (point) (point-min)) + (get-text-property (1- (point)) 'cl-print-ellipsis)) + (backward-char) + (user-error "No ellipsis to expand here"))) + (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) + (begin (previous-single-property-change end 'cl-print-ellipsis)) + (value (get-text-property begin 'cl-print-ellipsis))) + ;; FIXME: Rather than `t' (i.e. reuse the print-length/level unchanged), + ;; I think it would make sense to increase the level by 1 and to + ;; double the length at each expansion step. + (funcall cl-print-expand-ellipsis-function + begin end value t) + (goto-char begin))) + (defun cl-print-insert-ellipsis (object start stream) "Print \"...\" to STREAM with the `cl-print-ellipsis' text property. Save state in the text property in order to print the elided part -of OBJECT later. START should be 0 if the whole OBJECT is being +of OBJECT later. START should be nil if the whole OBJECT is being elided, otherwise it should be an index or other pointer into the internals of OBJECT which can be passed to `cl-print-object-contents' at a future time." @@ -423,11 +475,12 @@ STREAM should be a buffer. OBJECT and START are as described in `cl-print-insert-ellipsis'." (let ((value (list object start cl-print--number-table cl-print--currently-printing))) + ;; FIXME: Make it into a button! (with-current-buffer stream - (put-text-property beg end 'cl-print-ellipsis value stream)))) + (put-text-property beg end 'cl-print-ellipsis value stream) + (make-text-button beg end :type 'cl-print-ellipsis)))) -;;;###autoload -(defun cl-print-expand-ellipsis (value stream) +(defun cl-print--expand-ellipsis (value stream) "Print the expansion of an ellipsis to STREAM. VALUE should be the value of the `cl-print-ellipsis' text property which was attached to the ellipsis by `cl-prin1'." @@ -439,7 +492,7 @@ which was attached to the ellipsis by `cl-prin1'." (cl-print--currently-printing (nth 3 value))) (when (eq object (car cl-print--currently-printing)) (pop cl-print--currently-printing)) - (if (equal start 0) + (if (memq start '(0 nil)) (cl-print-object object stream) (cl-print-object-contents object start stream)))) @@ -474,22 +527,25 @@ characters with appropriate settings of `print-level' and the arguments VALUE and STREAM and which should respect `print-length' and `print-level'. LIMIT may be nil or zero in which case PRINT-FUNCTION will be called with `print-level' and -`print-length' bound to nil. +`print-length' bound to nil, and it can also be t in which case +PRINT-FUNCTION will be called with the current values of `print-level' +and `print-length'. Use this function with `cl-prin1' to print an object, -abbreviating it with ellipses to fit within a size limit. Use -this function with `cl-prin1-expand-ellipsis' to expand an -ellipsis, abbreviating the expansion to stay within a size -limit." - (setq limit (and (natnump limit) - (not (zerop limit)) - limit)) +abbreviating it with ellipses to fit within a size limit." + (setq limit (and (not (eq limit 0)) limit)) ;; Since this is used by the debugger when stack space may be ;; limited, if you increase print-level here, add more depth in ;; call_debugger (bug#31919). - (let* ((print-length (when limit (min limit 50))) - (print-level (when limit (min 8 (truncate (log limit))))) - (delta-length (when limit + (let* ((print-length (cond + ((null limit) nil) + ((eq limit t) print-length) + (t (min limit 50)))) + (print-level (cond + ((null limit) nil) + ((eq limit t) print-level) + (t (min 8 (truncate (log limit)))))) + (delta-length (when (natnump limit) (max 1 (truncate (/ print-length print-level)))))) (with-temp-buffer (catch 'done @@ -499,7 +555,7 @@ limit." (let ((result (- (point-max) (point-min)))) ;; Stop when either print-level is too low or the value is ;; successfully printed in the space allowed. - (when (or (not limit) (< result limit) (<= print-level 2)) + (when (or (not (natnump limit)) (< result limit) (<= print-level 2)) (throw 'done (buffer-string))) (let* ((ratio (/ result limit)) (delta-level (max 1 (min (- print-level 2) ratio)))) diff --git a/lisp/ielm.el b/lisp/ielm.el index 5c370733c05..01550de71b5 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -500,6 +500,11 @@ behavior of the indirect buffer." "Run `ielm-indirect-setup-hook'." (run-hooks 'ielm-indirect-setup-hook)) +(defun ielm--expand-ellipsis (orig-fun beg &rest args) + (let ((end (copy-marker (apply orig-fun beg args) t))) + (funcall pp-default-function beg end) + end)) + ;;; Major mode (define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM" @@ -582,6 +587,8 @@ Customized bindings may be defined in `ielm-map', which currently contains: (setq-local comment-use-syntax t) (setq-local lexical-binding t) + (add-function :around (local 'cl-print-expand-ellipsis-function) + #'ielm--expand-ellipsis) (setq-local indent-line-function #'ielm-indent-line) (setq-local ielm-working-buffer (current-buffer)) (setq-local fill-paragraph-function #'lisp-fill-paragraph) diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index af94dae310c..3073a42e39d 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'cl-print) (cl-defstruct (cl-print-tests-struct (:constructor cl-print-tests-con)) @@ -113,7 +114,7 @@ (should pos) (setq value (get-text-property pos 'cl-print-ellipsis result)) (should (equal expected result)) - (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + (should (equal expanded (with-output-to-string (cl-print--expand-ellipsis value nil)))))) (defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) @@ -122,7 +123,7 @@ (value (get-text-property pos 'cl-print-ellipsis result))) (should (string-match expected result)) (should (string-match expanded (with-output-to-string - (cl-print-expand-ellipsis value nil)))))) + (cl-print--expand-ellipsis value nil)))))) (ert-deftest cl-print-tests-print-to-string-with-limit () (let* ((thing10 (make-list 10 'a))