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 8150c71af11..d0bbec18519 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -109,6 +109,10 @@ window systems other than Nextstep.
When this minor mode is enabled, buttons representing modifier keys
are displayed along the tool bar.
+** 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
@@ -613,6 +617,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/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 65abb81ec46..b01595943fc 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -128,7 +128,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/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/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/files.el b/lisp/files.el
index 95195f51503..2f9456e6605 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/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))
diff --git a/lisp/ielm.el b/lisp/ielm.el
index 1eeec5fbb84..b45db3ec97e 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/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
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
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/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
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)))
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 c3829d2a3a3..11bfc52a83f 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -166,6 +166,10 @@ file_get_char (file_stream stream)
# 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.
@@ -4721,10 +4725,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. */
@@ -4789,7 +4800,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')
{
@@ -4802,12 +4812,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;
}
@@ -5951,6 +5966,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 0eff789e599..8b7b8d8566e 100644
--- a/src/process.c
+++ b/src/process.c
@@ -7147,7 +7147,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;
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))
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