Merge remote-tracking branch 'origin/master' into feature/android

This commit is contained in:
Po Lu 2023-07-14 07:58:49 +08:00
commit a65960c5b9
20 changed files with 354 additions and 148 deletions

View file

@ -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

View file

@ -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

View file

@ -1927,6 +1927,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
Local variables:
coding: utf-8
mode: outline
mode: emacs-news
paragraph-separate: "[ ]*$"
end:

View file

@ -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")))

View file

@ -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

View file

@ -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)

View file

@ -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 "#<hash-table " stream)
(princ (hash-table-test object) stream)
(princ " " stream)
@ -158,6 +163,9 @@ into a button whose action shows the function's disassembly.")
(autoload 'disassemble-1 "disass")
;; FIXME: Don't degenerate to `prin1' for the contents of char-tables
;; and records!
(cl-defmethod cl-print-object ((object compiled-function) stream)
(unless stream (setq stream standard-output))
;; We use "#f(...)" rather than "#<...>" 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))))

View file

@ -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

View file

@ -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))

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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."

View file

@ -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

View file

@ -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)))

View file

@ -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

View file

@ -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 (&not_a_number[negative]);
}
#endif
DEFSYM (Qinhibit_file_name_operation, "inhibit-file-name-operation");
DEFSYM (Qascii_character, "ascii-character");
DEFSYM (Qfunction, "function");

View file

@ -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;

View file

@ -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))

129
test/lisp/uniquify-tests.el Normal file
View file

@ -0,0 +1,129 @@
;;; uniquify-tests.el --- Tests for uniquify -*- lexical-binding: t; -*-
;; Copyright (C) 2023 Free Software Foundation, Inc.
;; Author: Spencer Baugh <sbaugh@janestreet.com>
;; 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 <https://www.gnu.org/licenses/>.
;;; 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<c>" "z<b>"))
(push (find-file-noselect "a/b/d/z") bufs)
(names-are '("z<d>" "z<c>" "z<b>"))
(push (find-file-noselect "e/b/z") bufs)
(names-are '("z<e/b>" "z<d>" "z<c>" "z<a/b>"))
;; buffers without a buffer-file-name don't get uniquified by uniquify
(push (generate-new-buffer "z") bufs)
(names-are '("z" "z<e/b>" "z<d>" "z<c>" "z<a/b>"))
;; but they do get uniquified by the C code which uses <n>
(push (generate-new-buffer "z") bufs)
(names-are '("z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>"))
(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<f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave)
;; somewhat confusing behavior results if a buffer is renamed to match an already-uniquified buffer
(rename-buffer "z<a/b>" t)
(names-are '("z<a/b><f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") '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