summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/emacs-lisp/checkdoc.el2
-rw-r--r--lisp/emacs-lisp/rx.el82
-rw-r--r--lisp/gnus/gnus-art.el6
-rw-r--r--lisp/gnus/spam-stat.el2
-rw-r--r--lisp/international/mule.el2
-rw-r--r--lisp/tab-line.el36
-rw-r--r--lisp/vc/vc-cvs.el21
-rw-r--r--lisp/window.el13
8 files changed, 101 insertions, 63 deletions
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index ccdddb47c35..e15836ee7d8 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -2073,7 +2073,7 @@ If the offending word is in a piece of quoted text, then it is skipped."
;; piece of an abbreviation
;; FIXME etc
(looking-at
- "\\([a-zA-Z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\."))
+ "\\([a-zA-Z]\\|[iI]\\.?e\\|[eE]\\.?g\\|[cC]f\\)\\."))
(error t))))
(if (checkdoc-autofix-ask-replace
b e
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index b4cab5715da..a0b2444346a 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -254,22 +254,39 @@ Left-fold the list L, starting with X, by the binary function F."
(setq l (cdr l)))
x)
+(defun rx--normalise-or-arg (form)
+ "Normalise the `or' argument FORM.
+Characters become strings, user-definitions and `eval' forms are expanded,
+and `or' forms are normalised recursively."
+ (cond ((characterp form)
+ (char-to-string form))
+ ((and (consp form) (memq (car form) '(or |)))
+ (cons (car form) (mapcar #'rx--normalise-or-arg (cdr form))))
+ ((and (consp form) (eq (car form) 'eval))
+ (rx--normalise-or-arg (rx--expand-eval (cdr form))))
+ (t
+ (let ((expanded (rx--expand-def form)))
+ (if expanded
+ (rx--normalise-or-arg expanded)
+ form)))))
+
+(defun rx--all-string-or-args (body)
+ "If BODY only consists of strings or such `or' forms, return all the strings.
+Otherwise throw `rx--nonstring'."
+ (mapcan (lambda (form)
+ (cond ((stringp form) (list form))
+ ((and (consp form) (memq (car form) '(or |)))
+ (rx--all-string-or-args (cdr form)))
+ (t (throw 'rx--nonstring nil))))
+ body))
+
(defun rx--translate-or (body)
"Translate an or-pattern of zero or more rx items.
Return (REGEXP . PRECEDENCE)."
;; FIXME: Possible improvements:
;;
- ;; - Turn single characters to strings: (or ?a ?b) -> (or "a" "b"),
- ;; so that they can be candidates for regexp-opt.
- ;;
- ;; - Translate compile-time strings (`eval' forms), again for regexp-opt.
- ;;
;; - Flatten sub-patterns first: (or (or A B) (or C D)) -> (or A B C D)
- ;; in order to improve effectiveness of regexp-opt.
- ;; This would also help composability.
- ;;
- ;; - Use associativity to run regexp-opt on contiguous subsets of arguments
- ;; if not all of them are strings. Example:
+ ;; Then call regexp-opt on runs of string arguments. Example:
;; (or (+ digit) "CHARLIE" "CHAN" (+ blank))
;; -> (or (+ digit) (or "CHARLIE" "CHAN") (+ blank))
;;
@@ -279,33 +296,32 @@ Return (REGEXP . PRECEDENCE)."
;; so that (or "@" "%" digit (any "A-Z" space) (syntax word))
;; -> (any "@" "%" digit "A-Z" space word)
;; -> "[A-Z@%[:digit:][:space:][:word:]]"
- ;;
- ;; Problem: If a subpattern is carefully written to be
- ;; optimizable by regexp-opt, how do we prevent the transforms
- ;; above from destroying that property?
- ;; Example: (or "a" (or "abc" "abd" "abe"))
(cond
((null body) ; No items: a never-matching regexp.
(rx--empty))
((null (cdr body)) ; Single item.
(rx--translate (car body)))
- ((rx--every #'stringp body) ; All strings.
- (cons (list (regexp-opt body nil))
- t))
- ((rx--every #'rx--charset-p body) ; All charsets.
- (rx--translate-union nil body))
(t
- (cons (append (car (rx--translate (car body)))
- (mapcan (lambda (item)
- (cons "\\|" (car (rx--translate item))))
- (cdr body)))
- nil))))
+ (let* ((args (mapcar #'rx--normalise-or-arg body))
+ (all-strings (catch 'rx--nonstring (rx--all-string-or-args args))))
+ (cond
+ (all-strings ; Only strings.
+ (cons (list (regexp-opt all-strings nil))
+ t))
+ ((rx--every #'rx--charset-p args) ; All charsets.
+ (rx--translate-union nil args))
+ (t
+ (cons (append (car (rx--translate (car args)))
+ (mapcan (lambda (item)
+ (cons "\\|" (car (rx--translate item))))
+ (cdr args)))
+ nil)))))))
(defun rx--charset-p (form)
"Whether FORM looks like a charset, only consisting of character intervals
and set operations."
(or (and (consp form)
- (or (and (memq (car form) '(any 'in 'char))
+ (or (and (memq (car form) '(any in char))
(rx--every (lambda (x) (not (symbolp x))) (cdr form)))
(and (memq (car form) '(not or | intersection))
(rx--every #'rx--charset-p (cdr form)))))
@@ -450,6 +466,10 @@ classes."
(not negated))
(cons (list (regexp-quote (char-to-string (caar items))))
t))
+ ;; Negated newline.
+ ((and (equal items '((?\n . ?\n)))
+ negated)
+ (rx--translate-symbol 'nonl))
;; At least one character or class, possibly negated.
(t
(cons
@@ -836,11 +856,15 @@ Return (REGEXP . PRECEDENCE)."
(cons (list (list 'regexp-quote arg)) 'seq))
(t (error "rx `literal' form with non-string argument")))))
-(defun rx--translate-eval (body)
- "Translate the `eval' form. Return (REGEXP . PRECEDENCE)."
+(defun rx--expand-eval (body)
+ "Expand `eval' arguments. Return a new rx form."
(unless (and body (null (cdr body)))
(error "rx `eval' form takes exactly one argument"))
- (rx--translate (eval (car body))))
+ (eval (car body)))
+
+(defun rx--translate-eval (body)
+ "Translate the `eval' form. Return (REGEXP . PRECEDENCE)."
+ (rx--translate (rx--expand-eval body)))
(defvar rx--regexp-atomic-regexp nil)
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 754655d6793..6b9610d3121 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -7774,11 +7774,11 @@ also be Lisp expression evaluating to a string),
BUTTON: is the number of the regexp grouping actually matching the button,
FORM: is a Lisp expression which must eval to true for the button to
be added,
-CALLBACK: is the function to call when the user push this button, and each
+CALLBACK: is the function to call when the user pushes this button, and each
PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
-CALLBACK can also be a variable, in that case the value of that
-variable it the real callback function."
+CALLBACK can also be a variable, in which case the value of that
+variable is the real callback function."
:group 'gnus-article-buttons
:type '(repeat (list (choice regexp variable sexp)
(integer :tag "Button")
diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el
index 8a4161e7acd..2e03608b5df 100644
--- a/lisp/gnus/spam-stat.el
+++ b/lisp/gnus/spam-stat.el
@@ -174,7 +174,7 @@ no effect when spam-stat is invoked through spam.el."
(defcustom spam-stat-score-buffer-user-functions nil
"List of additional scoring functions.
-Called one by one on the buffer.
+Called one by one on the buffer.
If all of these functions return non-nil answers, these numerical
answers are added to the computed spam stat score on the buffer. If
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 66594791209..86f3d2a34bf 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -2601,7 +2601,7 @@ This function is intended to be added to `auto-coding-functions'."
(detect-coding-region (point-min) size t)))))
;; Pure ASCII always comes back as undecided.
(if (memq detected
- '(utf-8 'utf-8-with-signature 'utf-8-hfs undecided))
+ '(utf-8 utf-8-with-signature utf-8-hfs undecided))
'utf-8
(warn "File contents detected as %s.
Consider adding an encoding attribute to the xml declaration,
diff --git a/lisp/tab-line.el b/lisp/tab-line.el
index 8f1221abe41..902c312ce14 100644
--- a/lisp/tab-line.el
+++ b/lisp/tab-line.el
@@ -446,17 +446,19 @@ variable `tab-line-tabs-function'."
(setq hscroll nil)
(set-window-parameter nil 'tab-line-hscroll hscroll))
(list separator
- (when (and (integerp hscroll) (not (zerop hscroll)))
+ (when (and (numberp hscroll) (not (zerop hscroll)))
tab-line-left-button)
- (when (if (integerp hscroll)
- (< (abs hscroll) (1- (length strings)))
+ (when (if (numberp hscroll)
+ (< (truncate hscroll) (1- (length strings)))
(> (length strings) 1))
tab-line-right-button)))
- (if hscroll (nthcdr (abs hscroll) strings) strings)
+ (if hscroll (nthcdr (truncate hscroll) strings) strings)
(when (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(list (concat separator (when tab-line-new-tab-choice
tab-line-new-button)))))))
+(defvar tab-line-auto-hscroll)
+
(defun tab-line-format ()
"Template for displaying tab line for selected window."
(let* ((tabs (funcall tab-line-tabs-function))
@@ -464,6 +466,13 @@ variable `tab-line-tabs-function'."
(window-buffer)
(window-parameter nil 'tab-line-hscroll)))
(cache (window-parameter nil 'tab-line-cache)))
+ ;; Enable auto-hscroll again after it was disabled on manual scrolling.
+ ;; The moment to enable it is when the window-buffer was updated.
+ (when (and tab-line-auto-hscroll ; if auto-hscroll was enabled
+ (integerp (nth 2 cache-key)) ; integer on manual scroll
+ cache ; window-buffer was updated
+ (not (equal (nth 1 (car cache)) (nth 1 cache-key))))
+ (set-window-parameter nil 'tab-line-hscroll (float (nth 2 cache-key))))
(or (and cache (equal (car cache) cache-key) (cdr cache))
(cdr (set-window-parameter
nil 'tab-line-cache
@@ -478,24 +487,27 @@ the selected tab visible."
:group 'tab-line
:version "27.1")
+(defvar tab-line-auto-hscroll-buffer (generate-new-buffer " *tab-line-hscroll*"))
+
(defun tab-line-auto-hscroll (strings hscroll)
- (with-temp-buffer
+ (with-current-buffer tab-line-auto-hscroll-buffer
(let ((truncate-partial-width-windows nil)
(inhibit-modification-hooks t)
show-arrows)
(setq truncate-lines nil)
+ (erase-buffer)
(apply 'insert strings)
(goto-char (point-min))
(add-face-text-property (point-min) (point-max) 'tab-line)
;; Continuation means tab-line doesn't fit completely,
;; thus scroll arrows are needed for scrolling.
(setq show-arrows (> (vertical-motion 1) 0))
- ;; Try to auto-scroll only when scrolling is needed,
+ ;; Try to auto-hscroll only when scrolling is needed,
;; but no manual scrolling was performed before.
(when (and tab-line-auto-hscroll
show-arrows
;; Do nothing when scrolled manually
- (not (and (integerp hscroll) (>= hscroll 0))))
+ (not (integerp hscroll)))
(let ((selected (seq-position strings 'selected
(lambda (str prop)
(get-pos-property 1 prop str)))))
@@ -503,7 +515,7 @@ the selected tab visible."
((null selected)
;; Do nothing if no tab is selected
)
- ((or (not (integerp hscroll)) (< selected (abs hscroll)))
+ ((or (not (numberp hscroll)) (< selected (truncate hscroll)))
;; Selected is scrolled to the left, or no scrolling yet
(erase-buffer)
(apply 'insert (reverse (seq-subseq strings 0 (1+ selected))))
@@ -520,14 +532,14 @@ the selected tab visible."
(lambda (str tab)
(eq (get-pos-property 1 'tab str) tab))))))
(when new-hscroll
- (setq hscroll (- new-hscroll))
+ (setq hscroll (float new-hscroll))
(set-window-parameter nil 'tab-line-hscroll hscroll)))
(setq hscroll nil)
(set-window-parameter nil 'tab-line-hscroll hscroll)))
(t
;; Check if the selected tab is already visible
(erase-buffer)
- (apply 'insert (seq-subseq strings (abs hscroll) (1+ selected)))
+ (apply 'insert (seq-subseq strings (truncate hscroll) (1+ selected)))
(goto-char (point-min))
(add-face-text-property (point-min) (point-max) 'tab-line)
(when (> (vertical-motion 1) 0)
@@ -547,7 +559,7 @@ the selected tab visible."
(lambda (str tab)
(eq (get-pos-property 1 'tab str) tab))))))
(when new-hscroll
- (setq hscroll (- new-hscroll))
+ (setq hscroll (float new-hscroll))
(set-window-parameter nil 'tab-line-hscroll hscroll)))))))))
(list show-arrows hscroll))))
@@ -559,7 +571,7 @@ the selected tab visible."
(funcall tab-line-tabs-function))))
(set-window-parameter
window 'tab-line-hscroll
- (max 0 (min (+ (if (integerp hscroll) (abs hscroll) 0) (or arg 1))
+ (max 0 (min (+ (if (numberp hscroll) (truncate hscroll) 0) (or arg 1))
(1- (length tabs)))))
(when window
(force-mode-line-update t))))
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index b6afda69198..e8231ecb289 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -1222,23 +1222,24 @@ is non-nil."
(defun vc-cvs-ignore (file &optional directory _remove)
"Ignore FILE under CVS.
-FILE is either absolute or relative to DIRECTORY. The basename
-of FILE is written unmodified into the ignore file and is
+FILE is either absolute or relative to DIRECTORY. The non-directory
+part of FILE is written unmodified into the ignore file and is
therefore evaluated by CVS as an ignore pattern which follows
glob(7) syntax. If the pattern should match any of the special
-characters ‘?*[\\\’ literally, they must be escaped with a
+characters `?*[\\' literally, they must be escaped with a
backslash.
CVS processes one ignore file for each subdirectory. Patterns
are separated by whitespace and only match files in the same
directory. Since FILE can be a relative filename with leading
-diretories, FILE is expanded against DIRECTORY to determine the
-correct absolute filename. The directory name of this path is
-then used to determine the location of the ignore file. The base
-name of this path is used as pattern for the ignore file.
-
-Since patterns are whitespace sparated, it is usually better to
-replace spaces in filenames with question marks ‘?’."
+directories, FILE is expanded against DIRECTORY to determine the
+correct absolute filename. The directory part of the resulting name
+is then used to determine the location of the ignore file. The
+non-directory part of the name is used as pattern for the ignore file.
+
+Since patterns are whitespace-separated, filenames containing spaces
+cannot be represented directly. A work-around is to replace such
+spaces with question marks."
(setq file (directory-file-name (expand-file-name file directory)))
(vc-cvs-append-to-ignore (file-name-directory file) (file-name-nondirectory file)))
diff --git a/lisp/window.el b/lisp/window.el
index bd825c09e16..b1a0294ae91 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -8806,8 +8806,7 @@ parameters of FRAME."
(parent (frame-parent frame))
(monitor-attributes
(unless parent
- (car (display-monitor-attributes-list
- (frame-parameter frame 'display)))))
+ (frame-monitor-attributes frame)))
;; FRAME'S parent or display sizes. Used in connection
;; with margins.
(geometry
@@ -8816,11 +8815,11 @@ parameters of FRAME."
(parent-or-display-width
(if parent
(frame-native-width parent)
- (- (nth 2 geometry) (nth 0 geometry))))
+ (nth 2 geometry)))
(parent-or-display-height
(if parent
(frame-native-height parent)
- (- (nth 3 geometry) (nth 1 geometry))))
+ (nth 3 geometry)))
;; FRAME's parent or workarea sizes. Used when no margins
;; are specified.
(parent-or-workarea
@@ -8882,13 +8881,15 @@ parameters of FRAME."
(window--sanitize-margin
(nth 2 margins) left-margin
parent-or-display-width))
- (nth 2 parent-or-workarea)))
+ (+ (nth 0 parent-or-workarea)
+ (nth 2 parent-or-workarea))))
(bottom-margin (if (nth 3 margins)
(- parent-or-display-height
(window--sanitize-margin
(nth 3 margins) top-margin
parent-or-display-height))
- (nth 3 parent-or-workarea)))
+ (+ (nth 1 parent-or-workarea)
+ (nth 3 parent-or-workarea))))
;; Minimum and maximum sizes specified for FRAME.
(sizes (or (frame-parameter frame 'fit-frame-to-buffer-sizes)
fit-frame-to-buffer-sizes))
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-30 00:29:36 +0000