417 lines
16 KiB
EmacsLisp
417 lines
16 KiB
EmacsLisp
;;; compat-31.el --- Functionality added in Emacs 31 -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2025-2026 Free Software Foundation, Inc.
|
|
|
|
;; 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:
|
|
|
|
;; Functionality added in Emacs 31, needed by older Emacs versions.
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (load "compat-macs.el" nil t t))
|
|
(compat-require compat-30 "30.1")
|
|
|
|
;; TODO Update to 31.1 as soon as the Emacs emacs-31 branch version bumped
|
|
(compat-version "31.0.50")
|
|
|
|
;;;; Defined in subr.el
|
|
|
|
(compat-defun error-type-p (symbol) ;; <compat-tests:error-api>
|
|
"Return non-nil if SYMBOL is a condition type."
|
|
(get symbol 'error-conditions))
|
|
|
|
(compat-defun error-has-type-p (error condition) ;; <compat-tests:error-api>
|
|
"Return non-nil if ERROR is of type CONDITION (or a subtype of it)."
|
|
(unless (let ((type (car-safe error)))
|
|
(and type (symbolp type) (listp (cdr error))
|
|
(error-type-p type)))
|
|
(signal 'wrong-type-argument (list error)))
|
|
(or (eq condition t)
|
|
(memq condition (get (car error) 'error-conditions))))
|
|
|
|
(compat-defalias error-type car ;; <compat-tests:error-api>
|
|
"Return the symbol which represents the type of ERROR.
|
|
\n(fn ERROR)")
|
|
|
|
(compat-defalias error-slot-value elt ;; <compat-tests:error-api>
|
|
"Access the SLOT of object ERROR.
|
|
Slots are specified by position, and slot 0 is the error symbol.
|
|
\n(fn ERROR SLOT)")
|
|
|
|
(compat-defun ensure-proper-list (object) ;; <compat-tests:ensure-proper-list>
|
|
"Return OBJECT as a list.
|
|
If OBJECT is already a proper list, return OBJECT itself. If it's not a
|
|
proper list, return a one-element list containing OBJECT.
|
|
|
|
`ensure-list' is usually preferable because that function runs in
|
|
constant time, but this one has to traverse the whole of OBJECT."
|
|
(declare (side-effect-free error-free))
|
|
(if (proper-list-p object)
|
|
object
|
|
(list object)))
|
|
|
|
(compat-defun set-local (variable value) ;; <compat-tests:set-local>
|
|
"Make VARIABLE buffer local and set it to VALUE."
|
|
(set (make-local-variable variable) value))
|
|
|
|
(compat-defun take-while (pred list) ;; <compat-tests:take-while>
|
|
"Return the longest prefix of LIST whose elements satisfy PRED."
|
|
(let ((r nil))
|
|
(while (and list (funcall pred (car list)))
|
|
(push (car list) r)
|
|
(setq list (cdr list)))
|
|
(nreverse r)))
|
|
|
|
(compat-defun drop-while (pred list) ;; <compat-tests:drop-while>
|
|
"Skip initial elements of LIST satisfying PRED and return the rest."
|
|
(while (and list (funcall pred (car list)))
|
|
(setq list (cdr list)))
|
|
list)
|
|
|
|
(compat-defun all (pred list) ;; <compat-tests:all>
|
|
"Non-nil if PRED is true for all elements in LIST."
|
|
(not (drop-while pred list)))
|
|
|
|
(compat-defun member-if (pred list) ;; <compat-tests:member-if>
|
|
"Non-nil if PRED is true for at least one element in LIST.
|
|
Returns the LIST suffix starting at the first element that satisfies PRED,
|
|
or nil if none does."
|
|
(drop-while (lambda (x) (not (funcall pred x))) list))
|
|
|
|
(compat-defalias any member-if) ;; <compat-tests:member-if>
|
|
|
|
(compat-defun hash-table-contains-p (key table) ;; <compat-tests:hash-table-contains-p>
|
|
"Return non-nil if TABLE has an element with KEY."
|
|
(declare (side-effect-free t))
|
|
(let ((missing '#:missing))
|
|
(not (eq (gethash key table missing) missing))))
|
|
|
|
(compat-defmacro static-when (condition &rest body) ;; <compat-tests:static-when>
|
|
"A conditional compilation macro.
|
|
Evaluate CONDITION at macro-expansion time. If it is non-nil,
|
|
expand the macro to evaluate all BODY forms sequentially and return
|
|
the value of the last one, or nil if there are none."
|
|
(declare (indent 1) (debug t))
|
|
(if body
|
|
(if (eval condition lexical-binding)
|
|
(cons 'progn body)
|
|
nil)
|
|
(macroexp-warn-and-return (format-message "`static-when' with empty body")
|
|
(list 'progn nil nil) '(empty-body static-when) t)))
|
|
|
|
(compat-defmacro static-unless (condition &rest body) ;; <compat-tests:static-unless>
|
|
"A conditional compilation macro.
|
|
Evaluate CONDITION at macro-expansion time. If it is nil,
|
|
expand the macro to evaluate all BODY forms sequentially and return
|
|
the value of the last one, or nil if there are none."
|
|
(declare (indent 1) (debug t))
|
|
(if body
|
|
(if (eval condition lexical-binding)
|
|
nil
|
|
(cons 'progn body))
|
|
(macroexp-warn-and-return (format-message "`static-unless' with empty body")
|
|
(list 'progn nil nil) '(empty-body static-unless) t)))
|
|
|
|
(compat-defun oddp (integer) ;; <compat-tests:oddp>
|
|
"Return t if INTEGER is odd."
|
|
(not (eq (% integer 2) 0)))
|
|
|
|
(compat-defun evenp (integer) ;; <compat-tests:evenp>
|
|
"Return t if INTEGER is even."
|
|
(eq (% integer 2) 0))
|
|
|
|
(compat-defun plusp (number) ;; <compat-tests:plusp>
|
|
"Return t if NUMBER is positive."
|
|
(> number 0))
|
|
|
|
(compat-defun minusp (number) ;; <compat-tests:minusp>
|
|
"Return t if NUMBER is negative."
|
|
(< number 0))
|
|
|
|
(compat-defmacro incf (place &optional delta) ;; <compat-tests:incf>
|
|
"Increment PLACE by DELTA (default to 1).
|
|
|
|
The DELTA is first added to PLACE, and then stored in PLACE.
|
|
Return the incremented value of PLACE.
|
|
|
|
See also `decf'."
|
|
(gv-letplace (getter setter) place
|
|
(funcall setter `(+ ,getter ,(or delta 1)))))
|
|
|
|
(compat-defmacro decf (place &optional delta) ;; <compat-tests:decf>
|
|
"Decrement PLACE by DELTA (default to 1).
|
|
|
|
The DELTA is first subtracted from PLACE, and then stored in PLACE.
|
|
Return the decremented value of PLACE.
|
|
|
|
See also `incf'."
|
|
(gv-letplace (getter setter) place
|
|
(funcall setter `(- ,getter ,(or delta 1)))))
|
|
|
|
;;;; Defined in color.el
|
|
|
|
(compat-defun color-blend (a b &optional alpha) ;; <compat-tests:color-blend>
|
|
"Blend the two colors A and B in linear space with ALPHA.
|
|
A and B should be lists (RED GREEN BLUE), where each element is
|
|
between 0.0 and 1.0, inclusive. ALPHA controls the influence A
|
|
has on the result and should be between 0.0 and 1.0, inclusive.
|
|
|
|
For instance:
|
|
|
|
(color-blend \\='(1 0.5 1) \\='(0 0 0) 0.75)
|
|
=> (0.75 0.375 0.75)"
|
|
(setq alpha (or alpha 0.5))
|
|
(let (blend)
|
|
(dotimes (i 3)
|
|
(push (+ (* (nth i a) alpha) (* (nth i b) (- 1 alpha))) blend))
|
|
(nreverse blend)))
|
|
|
|
;;;; Defined in time-date.el
|
|
|
|
(compat-defvar seconds-to-string ;; <compat-tests:seconds-to-string>
|
|
(list (list 1 "ms" 0.001)
|
|
(list 100 "s" 1)
|
|
(list (* 60 100) "m" 60.0)
|
|
(list (* 3600 30) "h" 3600.0)
|
|
(list (* 3600 24 400) "d" (* 3600.0 24.0))
|
|
(list nil "y" (* 365.25 24 3600)))
|
|
"Formatting used by the function `seconds-to-string'.")
|
|
|
|
(compat-defvar seconds-to-string-readable ;; <compat-tests:seconds-to-string>
|
|
`(("Y" "year" "years" ,(round (* 60 60 24 365.2425)))
|
|
("M" "month" "months" ,(round (* 60 60 24 30.436875)))
|
|
("w" "week" "weeks" ,(* 60 60 24 7))
|
|
("d" "day" "days" ,(* 60 60 24))
|
|
("h" "hour" "hours" ,(* 60 60))
|
|
("m" "minute" "minutes" 60)
|
|
("s" "second" "seconds" 1))
|
|
"Formatting used by the function `seconds-to-string' with READABLE set.
|
|
The format is an alist, with string keys ABBREV-UNIT, and elements like:
|
|
|
|
(ABBREV-UNIT UNIT UNIT-PLURAL SECS)
|
|
|
|
where UNIT is a unit of time, ABBREV-UNIT is the abbreviated form of
|
|
UNIT, UNIT-PLURAL is the plural form of UNIT, and SECS is the number of
|
|
seconds per UNIT.")
|
|
|
|
(compat-defun seconds-to-string (delay &optional readable abbrev precision) ;; <compat-tests:seconds-to-string>
|
|
"Handle optional arguments READABLE, ABBREV and PRECISION."
|
|
:extended t
|
|
(cond
|
|
((< delay 0)
|
|
(concat "-" (seconds-to-string (- delay) readable precision)))
|
|
(readable
|
|
(let* ((stsa seconds-to-string-readable)
|
|
(expanded (eq readable 'expanded))
|
|
digits
|
|
(round-to (cond
|
|
((wholenump precision)
|
|
(setq digits precision)
|
|
(expt 10 (- precision)))
|
|
((and (floatp precision) (< precision 1.))
|
|
(setq digits (- (floor (log precision 10))))
|
|
precision)
|
|
(t (setq digits 0) 1)))
|
|
(dformat (if (> digits 0) (format "%%0.%df" digits)))
|
|
(padding (if abbrev "" " "))
|
|
here cnt cnt-pre here-pre cnt-val isfloatp)
|
|
(if (= (round delay round-to) 0)
|
|
(format "0%s" (if abbrev "s" " seconds"))
|
|
(while (and (setq here (pop stsa)) stsa
|
|
(< (/ delay (nth 3 here)) 1)))
|
|
(or (and
|
|
expanded stsa ; smaller unit remains
|
|
(progn
|
|
(setq
|
|
here-pre here here (car stsa)
|
|
cnt-pre (floor (/ (float delay) (nth 3 here-pre)))
|
|
cnt (round
|
|
(/ (- (float delay) (* cnt-pre (nth 3 here-pre)))
|
|
(nth 3 here))
|
|
round-to))
|
|
(if (> cnt 0) t (setq cnt cnt-pre here here-pre here-pre nil))))
|
|
(setq cnt (round (/ (float delay) (nth 3 here)) round-to)))
|
|
(setq cnt-val (* cnt round-to)
|
|
isfloatp (and (> digits 0)
|
|
(> (- cnt-val (floor cnt-val)) 0.)))
|
|
(cl-labels
|
|
((unit (val here &optional plural)
|
|
(cond (abbrev (car here))
|
|
((and (not plural) (<= (floor val) 1)) (nth 1 here))
|
|
(t (nth 2 here)))))
|
|
(concat
|
|
(when here-pre
|
|
(concat (number-to-string cnt-pre) padding
|
|
(unit cnt-pre here-pre) " "))
|
|
(if isfloatp (format dformat cnt-val)
|
|
(number-to-string (floor cnt-val)))
|
|
padding
|
|
(unit cnt-val here isfloatp)))))) ; float formats are always plural
|
|
((= 0 delay) "0s")
|
|
(t (let ((sts seconds-to-string) here)
|
|
(while (and (car (setq here (pop sts)))
|
|
(<= (car here) delay)))
|
|
(concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here))))))
|
|
|
|
;;;; Defined in minibuffer.el
|
|
|
|
(compat-defun completion-list-candidate-at-point (&optional pt) ;; <compat-tests:completion-list-candidate-at-point>
|
|
"Candidate string and bounds at PT in completions buffer.
|
|
The return value has the format (STR BEG END).
|
|
The optional argument PT defaults to (point)."
|
|
(let ((pt (or pt (point))) beg end)
|
|
(cond
|
|
((and (/= pt (point-max)) (get-text-property pt 'mouse-face))
|
|
(setq end pt beg (1+ pt)))
|
|
((and (/= pt (point-min)) (get-text-property (1- pt) 'mouse-face))
|
|
(setq end (1- pt) beg pt)))
|
|
(when (and beg end)
|
|
(setq beg (previous-single-property-change beg 'mouse-face))
|
|
(setq end (or (next-single-property-change end 'mouse-face) (point-max)))
|
|
(list (or (get-text-property beg 'completion--string)
|
|
(buffer-substring beg end))
|
|
beg end))))
|
|
|
|
(compat-defun completion-table-with-metadata (table metadata) ;; <compat-tests:completion-table-with-metadata>
|
|
"Return new completion TABLE with METADATA.
|
|
METADATA should be an alist of completion metadata. See
|
|
`completion-metadata' for a list of supported metadata."
|
|
(lambda (string pred action)
|
|
(if (eq action 'metadata)
|
|
`(metadata . ,metadata)
|
|
(complete-with-action action table string pred))))
|
|
|
|
;;;; Defined in subr-x.el
|
|
|
|
(compat-defun add-remove--display-text-property (start end spec value &optional object remove) ;; <compat-tests:add-display-text-property>
|
|
"Helper function for `add-display-text-property' and `remove-display-text-property'."
|
|
(let ((sub-start start)
|
|
(sub-end 0)
|
|
(limit (if (stringp object)
|
|
(min (length object) end)
|
|
(min end (point-max))))
|
|
disp)
|
|
(while (< sub-end end)
|
|
(setq sub-end (next-single-property-change sub-start 'display object
|
|
limit))
|
|
(if (not (setq disp (get-text-property sub-start 'display object)))
|
|
(unless remove
|
|
(put-text-property sub-start sub-end 'display (list spec value)
|
|
object))
|
|
(let ((changed nil)
|
|
type)
|
|
(setq disp
|
|
(cond
|
|
((vectorp disp)
|
|
(setq type 'vector)
|
|
(seq-into disp 'list))
|
|
((or (not (consp (car-safe disp)))
|
|
(eq (caar disp) 'margin))
|
|
(setq type 'scalar)
|
|
(list disp))
|
|
(t
|
|
(setq type 'list)
|
|
disp)))
|
|
(when-let* ((old (assoc spec disp)))
|
|
(setq disp (if (eq type 'list)
|
|
(remove old disp)
|
|
(delete old disp))
|
|
changed t))
|
|
(unless remove
|
|
(setq disp (cons (list spec value) disp)
|
|
changed t))
|
|
(when changed
|
|
(if (not disp)
|
|
(remove-text-properties sub-start sub-end '(display nil) object)
|
|
(when (eq type 'vector)
|
|
(setq disp (seq-into disp 'vector)))
|
|
(put-text-property sub-start sub-end 'display disp object)))))
|
|
(setq sub-start sub-end))))
|
|
|
|
(compat-defun remove-display-text-property (start end spec &optional object) ;; <compat-tests:remove-display-text-property>
|
|
"Remove the display specification SPEC from the text from START to END.
|
|
SPEC is the car of the display specification to remove, e.g. `height'.
|
|
If any text in the region has other display specifications, those specs
|
|
are retained.
|
|
|
|
OBJECT is either a string or a buffer to remove the specification from.
|
|
If omitted, OBJECT defaults to the current buffer."
|
|
(add-remove--display-text-property start end spec nil object 'remove))
|
|
|
|
(compat-defvar work-buffer-limit 10 ;; <compat-tests:with-work-buffer>
|
|
"Maximum number of reusable work buffers.
|
|
When this limit is exceeded, newly allocated work buffers are
|
|
automatically killed, which means that in a such case
|
|
`with-work-buffer' becomes equivalent to `with-temp-buffer'.")
|
|
|
|
;; On Emacs 29 and newer `kill-all-local-variables' has a KILL-PERMANENT argument.
|
|
(static-if (< emacs-major-version 29) nil
|
|
(compat-defvar work-buffer--list nil ;; <compat-tests:with-work-buffer>
|
|
"List of work buffers.")
|
|
|
|
(compat-defun work-buffer--get () ;; <compat-tests:with-work-buffer>
|
|
"Get a work buffer."
|
|
(let ((buffer (pop work-buffer--list)))
|
|
(if (buffer-live-p buffer)
|
|
buffer
|
|
(generate-new-buffer " *work*" t))))
|
|
|
|
(compat-defun work-buffer--release (buffer) ;; <compat-tests:with-work-buffer>
|
|
"Release work BUFFER."
|
|
(if (buffer-live-p buffer)
|
|
(with-current-buffer buffer
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(delete-all-overlays))
|
|
(let (change-major-mode-hook)
|
|
(setq buffer-read-only nil)
|
|
(kill-all-local-variables t))
|
|
(push buffer work-buffer--list)))
|
|
(when (> (length work-buffer--list) work-buffer-limit)
|
|
(mapc #'kill-buffer (nthcdr work-buffer-limit work-buffer--list))
|
|
(setq work-buffer--list (ntake work-buffer-limit work-buffer--list)))))
|
|
|
|
(compat-defmacro with-work-buffer (&rest body) ;; <compat-tests:with-work-buffer>
|
|
"Create a work buffer, and evaluate BODY there like `progn'.
|
|
Like `with-temp-buffer', but reuse an already created temporary buffer
|
|
when possible, instead of creating a new one on each call. Avoid
|
|
retaining state referring to a work buffer, and kill any indirect
|
|
buffers you create that use a work buffer as a base."
|
|
(declare (indent 0) (debug t))
|
|
(static-if (< emacs-major-version 29)
|
|
`(with-temp-buffer ,@body)
|
|
(let ((work-buffer (make-symbol "work-buffer")))
|
|
`(let ((,work-buffer (work-buffer--get)))
|
|
(with-current-buffer ,work-buffer
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(work-buffer--release ,work-buffer)))))))
|
|
|
|
;;;; Defined in button.el
|
|
|
|
(compat-defun unbuttonize-region (start end) ;; <compat-tests:buttonize-region>
|
|
"Remove all the buttons between START and END.
|
|
This removes both text-property and overlay based buttons."
|
|
(dolist (o (overlays-in start end))
|
|
(when (overlay-get o 'button)
|
|
(delete-overlay o)))
|
|
(with-silent-modifications
|
|
(remove-text-properties start end (button--properties nil nil nil))
|
|
(add-face-text-property start end 'button nil)))
|
|
|
|
(provide 'compat-31)
|
|
;;; compat-31.el ends here
|