Merge remote-tracking branch 'origin/master' into feature/android
This commit is contained in:
commit
a65960c5b9
20 changed files with 354 additions and 148 deletions
|
@ -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
|
||||
|
|
12
etc/NEWS
12
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
|
||||
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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")))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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
|
||||
|
|
29
src/lread.c
29
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");
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
129
test/lisp/uniquify-tests.el
Normal 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
|
Loading…
Add table
Reference in a new issue