849 lines
35 KiB
EmacsLisp
849 lines
35 KiB
EmacsLisp
;;; compat-28.el --- Functionality added in Emacs 28.1 -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2021-2023 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 28.1, needed by older Emacs versions.
|
||
|
||
;;; Code:
|
||
|
||
(eval-when-compile (load "compat-macs.el" nil t t))
|
||
(compat-require compat-27 "27.1")
|
||
|
||
(compat-version "28.1")
|
||
|
||
;;;; Defined in fns.c
|
||
|
||
;; FIXME Should handle multibyte regular expressions
|
||
(compat-defun string-search (needle haystack &optional start-pos) ;; <compat-tests:string-search>
|
||
"Search for the string NEEDLE in the strign HAYSTACK.
|
||
|
||
The return value is the position of the first occurrence of
|
||
NEEDLE in HAYSTACK, or nil if no match was found.
|
||
|
||
The optional START-POS argument says where to start searching in
|
||
HAYSTACK and defaults to zero (start at the beginning).
|
||
It must be between zero and the length of HAYSTACK, inclusive.
|
||
|
||
Case is always significant and text properties are ignored.
|
||
|
||
NOTE: Prior to Emacs 27 `string-match' has issues handling
|
||
multibyte regular expressions. As the compatibility function
|
||
for `string-search' is implemented via `string-match', these
|
||
issues are inherited."
|
||
(when (and start-pos (or (< (length haystack) start-pos)
|
||
(< start-pos 0)))
|
||
(signal 'args-out-of-range (list start-pos)))
|
||
(save-match-data
|
||
(let ((case-fold-search nil))
|
||
(string-match (regexp-quote needle) haystack start-pos))))
|
||
|
||
(compat-defun length= (sequence length) ;; [[compat-tests:length=]]
|
||
"Returns non-nil if SEQUENCE has a length equal to LENGTH."
|
||
(cond
|
||
((null sequence) (zerop length))
|
||
((consp sequence)
|
||
(and (null (nthcdr length sequence))
|
||
(nthcdr (1- length) sequence)
|
||
t))
|
||
((arrayp sequence)
|
||
(= (length sequence) length))
|
||
((signal 'wrong-type-argument sequence))))
|
||
|
||
(compat-defun length< (sequence length) ;; [[compat-tests:length<]]
|
||
"Returns non-nil if SEQUENCE is shorter than LENGTH."
|
||
(cond
|
||
((null sequence) (not (zerop length)))
|
||
((listp sequence)
|
||
(null (nthcdr (1- length) sequence)))
|
||
((arrayp sequence)
|
||
(< (length sequence) length))
|
||
((signal 'wrong-type-argument sequence))))
|
||
|
||
(compat-defun length> (sequence length) ;; [[compat-tests:length>]]
|
||
"Returns non-nil if SEQUENCE is longer than LENGTH."
|
||
(cond
|
||
((listp sequence)
|
||
(and (nthcdr length sequence) t))
|
||
((arrayp sequence)
|
||
(> (length sequence) length))
|
||
((signal 'wrong-type-argument sequence))))
|
||
|
||
;;;; Defined in fileio.c
|
||
|
||
(compat-defun file-name-concat (directory &rest components) ;; <compat-tests:file-name-concat>
|
||
"Append COMPONENTS to DIRECTORY and return the resulting string.
|
||
Elements in COMPONENTS must be a string or nil.
|
||
DIRECTORY or the non-final elements in COMPONENTS may or may not end
|
||
with a slash -- if they don’t end with a slash, a slash will be
|
||
inserted before contatenating."
|
||
(let ((separator (eval-when-compile
|
||
(if (memq system-type '(ms-dos windows-nt cygwin))
|
||
"\\" "/")))
|
||
(components (delq nil
|
||
(mapcar (lambda (x) (and (not (equal "" x)) x))
|
||
(cons directory components))))
|
||
(result ""))
|
||
(while components
|
||
(let ((c (pop components)))
|
||
(setq result (concat result c
|
||
(and components
|
||
(not (string-suffix-p separator c))
|
||
separator)))))
|
||
result))
|
||
|
||
;;;; Defined in alloc.c
|
||
|
||
(compat-defalias garbage-collect-maybe ignore) ;; <compat-tests:garbage-collect-maybe>
|
||
|
||
;;;; Defined in characters.c
|
||
|
||
(compat-defun string-width (string &optional from to) ;; <compat-tests:string-width>
|
||
"Handle optional arguments FROM and TO."
|
||
:extended t
|
||
(let* ((len (length string))
|
||
(from (or from 0))
|
||
(to (or to len)))
|
||
(if (and (= from 0) (= to len))
|
||
(string-width string)
|
||
(string-width (substring string from to)))))
|
||
|
||
;;;; Defined in dired.c
|
||
|
||
(compat-defun directory-files (directory &optional full match nosort count) ;; <compat-tests:directory-files>
|
||
"Handle additional optional argument COUNT."
|
||
:extended t
|
||
(let ((files (directory-files directory full match nosort)))
|
||
(when (natnump count)
|
||
(setf (nthcdr count files) nil))
|
||
files))
|
||
|
||
(compat-defun directory-files-and-attributes (directory &optional full match nosort id-format count) ;; <compat-tests:directory-files-and-attributs>
|
||
"Handle additional optional argument COUNT."
|
||
:extended t
|
||
(let ((files (directory-files-and-attributes directory full match nosort id-format)))
|
||
(when (natnump count)
|
||
(setf (nthcdr count files) nil))
|
||
files))
|
||
|
||
;;;; xfaces.c
|
||
|
||
(compat-defun color-values-from-color-spec (spec) ;; <compat-tests:color-values-from-color-spec>
|
||
"Parse color SPEC as a numeric color and return (RED GREEN BLUE).
|
||
This function recognises the following formats for SPEC:
|
||
|
||
#RGB, where R, G and B are hex numbers of equal length, 1-4 digits each.
|
||
rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each.
|
||
rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1].
|
||
|
||
If SPEC is not in one of the above forms, return nil.
|
||
|
||
Each of the 3 integer members of the resulting list, RED, GREEN,
|
||
and BLUE, is normalized to have its value in [0,65535]."
|
||
(let ((case-fold-search nil))
|
||
(save-match-data
|
||
(cond
|
||
((string-match
|
||
;; (rx bos "#"
|
||
;; (or (: (group-n 1 (= 1 hex)) (group-n 2 (= 1 hex)) (group-n 3 (= 1 hex)))
|
||
;; (: (group-n 1 (= 2 hex)) (group-n 2 (= 2 hex)) (group-n 3 (= 2 hex)))
|
||
;; (: (group-n 1 (= 3 hex)) (group-n 2 (= 3 hex)) (group-n 3 (= 3 hex)))
|
||
;; (: (group-n 1 (= 4 hex)) (group-n 2 (= 4 hex)) (group-n 3 (= 4 hex))))
|
||
;; eos)
|
||
"\\`#\\(?:\\(?1:[[:xdigit:]]\\{1\\}\\)\\(?2:[[:xdigit:]]\\{1\\}\\)\\(?3:[[:xdigit:]]\\{1\\}\\)\\|\\(?1:[[:xdigit:]]\\{2\\}\\)\\(?2:[[:xdigit:]]\\{2\\}\\)\\(?3:[[:xdigit:]]\\{2\\}\\)\\|\\(?1:[[:xdigit:]]\\{3\\}\\)\\(?2:[[:xdigit:]]\\{3\\}\\)\\(?3:[[:xdigit:]]\\{3\\}\\)\\|\\(?1:[[:xdigit:]]\\{4\\}\\)\\(?2:[[:xdigit:]]\\{4\\}\\)\\(?3:[[:xdigit:]]\\{4\\}\\)\\)\\'"
|
||
spec)
|
||
(let ((max (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4)))))
|
||
(list (/ (* (string-to-number (match-string 1 spec) 16) 65535) max)
|
||
(/ (* (string-to-number (match-string 2 spec) 16) 65535) max)
|
||
(/ (* (string-to-number (match-string 3 spec) 16) 65535) max))))
|
||
((string-match
|
||
;; (rx bos "rgb:"
|
||
;; (group (** 1 4 hex)) "/"
|
||
;; (group (** 1 4 hex)) "/"
|
||
;; (group (** 1 4 hex))
|
||
;; eos)
|
||
"\\`rgb:\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)\\'"
|
||
spec)
|
||
(list (/ (* (string-to-number (match-string 1 spec) 16) 65535)
|
||
(1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4))))
|
||
(/ (* (string-to-number (match-string 2 spec) 16) 65535)
|
||
(1- (ash 1 (* (- (match-end 2) (match-beginning 2)) 4))))
|
||
(/ (* (string-to-number (match-string 3 spec) 16) 65535)
|
||
(1- (ash 1 (* (- (match-end 3) (match-beginning 3)) 4))))))
|
||
;; The "RGBi" (RGB Intensity) specification is defined by
|
||
;; XCMS[0], see [1] for the implementation in Xlib.
|
||
;;
|
||
;; [0] http://www.nic.funet.fi/pub/X11/X11R4/DOCS/color/Xcms.text
|
||
;; [1] https://gitlab.freedesktop.org/xorg/lib/libx11/-/blob/master/src/xcms/LRGB.c#L1392
|
||
((string-match
|
||
;; (rx bos "rgbi:" (* space)
|
||
;; (group (? (or "-" "+"))
|
||
;; (or (: (+ digit) (? "." (* digit)))
|
||
;; (: "." (+ digit)))
|
||
;; (? "e" (? (or "-" "+")) (+ digit)))
|
||
;; "/" (* space)
|
||
;; (group (? (or "-" "+"))
|
||
;; (or (: (+ digit) (? "." (* digit)))
|
||
;; (: "." (+ digit)))
|
||
;; (? "e" (? (or "-" "+")) (+ digit)))
|
||
;; "/" (* space)
|
||
;; (group (? (or "-" "+"))
|
||
;; (or (: (+ digit) (? "." (* digit)))
|
||
;; (: "." (+ digit)))
|
||
;; (? "e" (? (or "-" "+")) (+ digit)))
|
||
;; eos)
|
||
"\\`rgbi:[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)\\'"
|
||
spec)
|
||
(let ((r (round (* (string-to-number (match-string 1 spec)) 65535)))
|
||
(g (round (* (string-to-number (match-string 2 spec)) 65535)))
|
||
(b (round (* (string-to-number (match-string 3 spec)) 65535))))
|
||
(when (and (<= 0 r) (<= r 65535)
|
||
(<= 0 g) (<= g 65535)
|
||
(<= 0 b) (<= b 65535))
|
||
(list r g b))))))))
|
||
|
||
;;;; Defined in simple.el
|
||
|
||
(compat-defun make-separator-line (&optional length) ;; <compat-tests:make-separator-line>
|
||
"Make a string appropriate for usage as a visual separator line.
|
||
If LENGTH is nil, use the window width."
|
||
(concat (propertize (make-string (or length (1- (window-width))) ?-)
|
||
'face 'separator-line)
|
||
"\n"))
|
||
|
||
;;;; Defined in subr.el
|
||
|
||
(compat-defun process-lines-handling-status (program status-handler &rest args) ;; <compat-tests:process-lines-handling-status>
|
||
"Execute PROGRAM with ARGS, returning its output as a list of lines.
|
||
If STATUS-HANDLER is non-nil, it must be a function with one
|
||
argument, which will be called with the exit status of the
|
||
program before the output is collected. If STATUS-HANDLER is
|
||
nil, an error is signaled if the program returns with a non-zero
|
||
exit status."
|
||
(with-temp-buffer
|
||
(let ((status (apply #'call-process program nil (current-buffer) nil args)))
|
||
(if status-handler
|
||
(funcall status-handler status)
|
||
(unless (eq status 0)
|
||
(error "%s exited with status %s" program status)))
|
||
(goto-char (point-min))
|
||
(let (lines)
|
||
(while (not (eobp))
|
||
(setq lines (cons (buffer-substring-no-properties
|
||
(line-beginning-position)
|
||
(line-end-position))
|
||
lines))
|
||
(forward-line 1))
|
||
(nreverse lines)))))
|
||
|
||
(compat-defun process-lines-ignore-status (program &rest args) ;; <compat-tests:process-lines-ignore-status>
|
||
"Execute PROGRAM with ARGS, returning its output as a list of lines.
|
||
The exit status of the program is ignored.
|
||
Also see `process-lines'."
|
||
(apply 'process-lines-handling-status program #'ignore args))
|
||
|
||
;; FIXME Should handle multibyte regular expressions
|
||
(compat-defun string-replace (fromstring tostring instring) ;; <compat-tests:string-replace>
|
||
"Replace FROMSTRING with TOSTRING in INSTRING each time it occurs."
|
||
(when (equal fromstring "")
|
||
(signal 'wrong-length-argument '(0)))
|
||
(let ((case-fold-search nil))
|
||
(replace-regexp-in-string
|
||
(regexp-quote fromstring)
|
||
tostring instring
|
||
t t)))
|
||
|
||
(compat-defun always (&rest _arguments) ;; <compat-tests:always>
|
||
"Do nothing and return t.
|
||
This function accepts any number of ARGUMENTS, but ignores them.
|
||
Also see `ignore'."
|
||
t)
|
||
|
||
(compat-defun insert-into-buffer (buffer &optional start end) ;; <compat-tests:insert-into-buffer>
|
||
"Insert the contents of the current buffer into BUFFER.
|
||
If START/END, only insert that region from the current buffer.
|
||
Point in BUFFER will be placed after the inserted text."
|
||
(let ((current (current-buffer)))
|
||
(with-current-buffer buffer
|
||
(insert-buffer-substring current start end))))
|
||
|
||
(compat-defun replace-string-in-region (string replacement &optional start end) ;; <compat-tests:replace-string-in-region>
|
||
"Replace STRING with REPLACEMENT in the region from START to END.
|
||
The number of replaced occurrences are returned, or nil if STRING
|
||
doesn't exist in the region.
|
||
|
||
If START is nil, use the current point. If END is nil, use `point-max'.
|
||
|
||
Comparisons and replacements are done with fixed case."
|
||
(if start
|
||
(when (< start (point-min))
|
||
(error "Start before start of buffer"))
|
||
(setq start (point)))
|
||
(if end
|
||
(when (> end (point-max))
|
||
(error "End after end of buffer"))
|
||
(setq end (point-max)))
|
||
(save-excursion
|
||
(goto-char start)
|
||
(save-restriction
|
||
(narrow-to-region start end)
|
||
(let ((matches 0)
|
||
(case-fold-search nil))
|
||
(while (search-forward string nil t)
|
||
(delete-region (match-beginning 0) (match-end 0))
|
||
(insert replacement)
|
||
(setq matches (1+ matches)))
|
||
(and (not (zerop matches))
|
||
matches)))))
|
||
|
||
(compat-defun replace-regexp-in-region (regexp replacement &optional start end) ;; <compat-tests:replace-regexp-in-region>
|
||
"Replace REGEXP with REPLACEMENT in the region from START to END.
|
||
The number of replaced occurrences are returned, or nil if REGEXP
|
||
doesn't exist in the region.
|
||
|
||
If START is nil, use the current point. If END is nil, use `point-max'.
|
||
|
||
Comparisons and replacements are done with fixed case.
|
||
|
||
REPLACEMENT can use the following special elements:
|
||
|
||
`\\&' in NEWTEXT means substitute original matched text.
|
||
`\\N' means substitute what matched the Nth `\\(...\\)'.
|
||
If Nth parens didn't match, substitute nothing.
|
||
`\\\\' means insert one `\\'.
|
||
`\\?' is treated literally."
|
||
(if start
|
||
(when (< start (point-min))
|
||
(error "Start before start of buffer"))
|
||
(setq start (point)))
|
||
(if end
|
||
(when (> end (point-max))
|
||
(error "End after end of buffer"))
|
||
(setq end (point-max)))
|
||
(save-excursion
|
||
(goto-char start)
|
||
(save-restriction
|
||
(narrow-to-region start end)
|
||
(let ((matches 0)
|
||
(case-fold-search nil))
|
||
(while (re-search-forward regexp nil t)
|
||
(replace-match replacement t)
|
||
(setq matches (1+ matches)))
|
||
(and (not (zerop matches))
|
||
matches)))))
|
||
|
||
(compat-defun buffer-local-boundp (symbol buffer) ;; <compat-tests:buffer-local-boundp>
|
||
"Return non-nil if SYMBOL is bound in BUFFER.
|
||
Also see `local-variable-p'."
|
||
(catch 'fail
|
||
(condition-case nil
|
||
(buffer-local-value symbol buffer)
|
||
(void-variable nil (throw 'fail nil)))
|
||
t))
|
||
|
||
(compat-defmacro with-existing-directory (&rest body) ;; <compat-tests:with-existing-directory>
|
||
"Execute BODY with `default-directory' bound to an existing directory.
|
||
If `default-directory' is already an existing directory, it's not changed."
|
||
(declare (indent 0) (debug t))
|
||
`(let ((default-directory
|
||
(or (catch 'quit
|
||
(dolist (dir (list default-directory
|
||
(expand-file-name "~/")
|
||
temporary-file-directory
|
||
(getenv "TMPDIR")
|
||
"/tmp/"))
|
||
(when (and dir (file-exists-p dir))
|
||
(throw 'quit dir))))
|
||
"/")))
|
||
,@body))
|
||
|
||
(compat-defmacro dlet (binders &rest body) ;; <compat-tests:dlet>
|
||
"Like `let' but using dynamic scoping."
|
||
(declare (indent 1) (debug let))
|
||
`(let (_)
|
||
,@(mapcar (lambda (binder)
|
||
`(defvar ,(if (consp binder) (car binder) binder)))
|
||
binders)
|
||
(let ,binders ,@body)))
|
||
|
||
(compat-defun ensure-list (object) ;; <compat-tests:ensure-list>
|
||
"Return OBJECT as a list.
|
||
If OBJECT is already a list, return OBJECT itself. If it's
|
||
not a list, return a one-element list containing OBJECT."
|
||
(if (listp object)
|
||
object
|
||
(list object)))
|
||
|
||
(compat-defalias subr-primitive-p subrp) ;; <compat-tests:subr-primitive-p>
|
||
|
||
;;;; Defined in data.c
|
||
|
||
(compat-defalias subr-native-elisp-p ignore) ;; <compat-tests:subr-native-elisp-p>
|
||
|
||
;;;; Defined in subr-x.el
|
||
|
||
(compat-defun string-clean-whitespace (string) ;; <compat-tests:string-clean-whitespace>
|
||
"Clean up whitespace in STRING.
|
||
All sequences of whitespaces in STRING are collapsed into a
|
||
single space character, and leading/trailing whitespace is
|
||
removed."
|
||
(let ((blank "[[:blank:]\r\n]+"))
|
||
(replace-regexp-in-string
|
||
"^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$"
|
||
""
|
||
(replace-regexp-in-string
|
||
blank " " string))))
|
||
|
||
(compat-defun string-fill (string length) ;; <compat-tests:string-fill>
|
||
"Clean up whitespace in STRING.
|
||
All sequences of whitespaces in STRING are collapsed into a
|
||
single space character, and leading/trailing whitespace is
|
||
removed."
|
||
(with-temp-buffer
|
||
(insert string)
|
||
(goto-char (point-min))
|
||
(let ((fill-column length)
|
||
(adaptive-fill-mode nil))
|
||
(fill-region (point-min) (point-max)))
|
||
(buffer-string)))
|
||
|
||
(compat-defun string-pad (string length &optional padding start) ;; <compat-tests:string-pad>
|
||
"Pad STRING to LENGTH using PADDING.
|
||
If PADDING is nil, the space character is used. If not nil, it
|
||
should be a character.
|
||
|
||
If STRING is longer than the absolute value of LENGTH, no padding
|
||
is done.
|
||
|
||
If START is nil (or not present), the padding is done to the end
|
||
of the string, and if non-nil, padding is done to the start of
|
||
the string."
|
||
(unless (natnump length)
|
||
(signal 'wrong-type-argument (list 'natnump length)))
|
||
(let ((pad-length (- length (length string))))
|
||
(if (< pad-length 0)
|
||
string
|
||
(concat (and start
|
||
(make-string pad-length (or padding ?\s)))
|
||
string
|
||
(and (not start)
|
||
(make-string pad-length (or padding ?\s)))))))
|
||
|
||
(compat-defun string-chop-newline (string) ;; <compat-tests:string-chop-newline>
|
||
"Remove the final newline (if any) from STRING."
|
||
(if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n))
|
||
(substring string 0 -1)
|
||
string))
|
||
|
||
(compat-defmacro named-let (name bindings &rest body) ;; <compat-tests:named-let>
|
||
"Looping construct taken from Scheme.
|
||
Like `let', bind variables in BINDINGS and then evaluate BODY,
|
||
but with the twist that BODY can evaluate itself recursively by
|
||
calling NAME, where the arguments passed to NAME are used
|
||
as the new values of the bound variables in the recursive invocation."
|
||
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
|
||
(let ((fargs (mapcar (lambda (b)
|
||
(let ((var (if (consp b) (car b) b)))
|
||
(make-symbol (symbol-name var))))
|
||
bindings))
|
||
(aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))
|
||
rargs)
|
||
(dotimes (i (length bindings))
|
||
(let ((b (nth i bindings)))
|
||
(push (list (if (consp b) (car b) b) (nth i fargs))
|
||
rargs)
|
||
(setf (if (consp b) (car b) b)
|
||
(nth i fargs))))
|
||
(letrec
|
||
((quit (make-symbol "quit")) (self (make-symbol "self"))
|
||
(total-tco t)
|
||
(macro (lambda (&rest args)
|
||
(setq total-tco nil)
|
||
`(funcall ,self . ,args)))
|
||
;; Based on `cl--self-tco':
|
||
(tco-progn (lambda (exprs)
|
||
(append
|
||
(butlast exprs)
|
||
(list (funcall tco (car (last exprs)))))))
|
||
(tco (lambda (expr)
|
||
(cond
|
||
((eq (car-safe expr) 'if)
|
||
(append (list 'if
|
||
(cadr expr)
|
||
(funcall tco (nth 2 expr)))
|
||
(funcall tco-progn (nthcdr 3 expr))))
|
||
((eq (car-safe expr) 'cond)
|
||
(let ((conds (cdr expr)) body)
|
||
(while conds
|
||
(let ((branch (pop conds)))
|
||
(push (cond
|
||
((cdr branch) ;has tail
|
||
(funcall tco-progn branch))
|
||
((null conds) ;last element
|
||
(list t (funcall tco (car branch))))
|
||
((progn
|
||
branch)))
|
||
body)))
|
||
(cons 'cond (nreverse body))))
|
||
((eq (car-safe expr) 'or)
|
||
(if (cddr expr)
|
||
(let ((var (make-symbol "var")))
|
||
`(let ((,var ,(cadr expr)))
|
||
(if ,var ,(funcall tco var)
|
||
,(funcall tco (cons 'or (cddr expr))))))
|
||
(funcall tco (cadr expr))))
|
||
((eq (car-safe expr) 'condition-case)
|
||
(append (list 'condition-case (cadr expr) (nth 2 expr))
|
||
(mapcar
|
||
(lambda (handler)
|
||
(cons (car handler)
|
||
(funcall tco-progn (cdr handler))))
|
||
(nthcdr 3 expr))))
|
||
((memq (car-safe expr) '(and progn))
|
||
(cons (car expr) (funcall tco-progn (cdr expr))))
|
||
((memq (car-safe expr) '(let let*))
|
||
(append (list (car expr) (cadr expr))
|
||
(funcall tco-progn (cddr expr))))
|
||
((eq (car-safe expr) name)
|
||
(let (sets (args (cdr expr)))
|
||
(dolist (farg fargs)
|
||
(push (list farg (pop args))
|
||
sets))
|
||
(cons 'setq (apply #'nconc (nreverse sets)))))
|
||
(`(throw ',quit ,expr))))))
|
||
(when-let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body)))))
|
||
(setq body `((catch ',quit
|
||
(while t (let ,rargs ,@(macroexp-unprogn tco-body)))))))
|
||
(let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro)))))
|
||
(if total-tco
|
||
`(let ,bindings ,expand)
|
||
`(funcall
|
||
(letrec ((,self (lambda ,fargs ,expand))) ,self)
|
||
,@aargs))))))
|
||
|
||
;;;; Defined in files.el
|
||
|
||
(compat-defun file-name-with-extension (filename extension) ;; <compat-tests:file-name-with-extension>
|
||
"Set the EXTENSION of a FILENAME.
|
||
The extension (in a file name) is the part that begins with the last \".\".
|
||
|
||
Trims a leading dot from the EXTENSION so that either \"foo\" or
|
||
\".foo\" can be given.
|
||
|
||
Errors if the FILENAME or EXTENSION are empty, or if the given
|
||
FILENAME has the format of a directory.
|
||
|
||
See also `file-name-sans-extension'."
|
||
(let ((extn (string-remove-prefix "." extension)))
|
||
(cond
|
||
((string= filename "")
|
||
(error "Empty filename"))
|
||
((string= extn "")
|
||
(error "Malformed extension: %s" extension))
|
||
((directory-name-p filename)
|
||
(error "Filename is a directory: %s" filename))
|
||
(t
|
||
(concat (file-name-sans-extension filename) "." extn)))))
|
||
|
||
(compat-defun directory-empty-p (dir) ;; <compat-tests:directory-empty-p>
|
||
"Return t if DIR names an existing directory containing no other files.
|
||
Return nil if DIR does not name a directory, or if there was
|
||
trouble determining whether DIR is a directory or empty.
|
||
|
||
Symbolic links to directories count as directories.
|
||
See `file-symlink-p' to distinguish symlinks."
|
||
(and (file-directory-p dir)
|
||
(null (directory-files dir nil directory-files-no-dot-files-regexp t))))
|
||
|
||
(compat-defun file-modes-number-to-symbolic (mode &optional filetype) ;; <compat-tests:file-modes-number-to-symbolic>
|
||
"Return a string describing a file's MODE.
|
||
For instance, if MODE is #o700, then it produces `-rwx------'.
|
||
FILETYPE if provided should be a character denoting the type of file,
|
||
such as `?d' for a directory, or `?l' for a symbolic link and will override
|
||
the leading `-' char."
|
||
(string
|
||
(or filetype
|
||
(pcase (ash mode -12)
|
||
;; POSIX specifies that the file type is included in st_mode
|
||
;; and provides names for the file types but values only for
|
||
;; the permissions (e.g., S_IWOTH=2).
|
||
|
||
;; (#o017 ??) ;; #define S_IFMT 00170000
|
||
(#o014 ?s) ;; #define S_IFSOCK 0140000
|
||
(#o012 ?l) ;; #define S_IFLNK 0120000
|
||
;; (8 ??) ;; #define S_IFREG 0100000
|
||
(#o006 ?b) ;; #define S_IFBLK 0060000
|
||
(#o004 ?d) ;; #define S_IFDIR 0040000
|
||
(#o002 ?c) ;; #define S_IFCHR 0020000
|
||
(#o001 ?p) ;; #define S_IFIFO 0010000
|
||
(_ ?-)))
|
||
(if (zerop (logand 256 mode)) ?- ?r)
|
||
(if (zerop (logand 128 mode)) ?- ?w)
|
||
(if (zerop (logand 64 mode))
|
||
(if (zerop (logand 2048 mode)) ?- ?S)
|
||
(if (zerop (logand 2048 mode)) ?x ?s))
|
||
(if (zerop (logand 32 mode)) ?- ?r)
|
||
(if (zerop (logand 16 mode)) ?- ?w)
|
||
(if (zerop (logand 8 mode))
|
||
(if (zerop (logand 1024 mode)) ?- ?S)
|
||
(if (zerop (logand 1024 mode)) ?x ?s))
|
||
(if (zerop (logand 4 mode)) ?- ?r)
|
||
(if (zerop (logand 2 mode)) ?- ?w)
|
||
(if (zerop (logand 512 mode))
|
||
(if (zerop (logand 1 mode)) ?- ?x)
|
||
(if (zerop (logand 1 mode)) ?T ?t))))
|
||
|
||
(compat-defun file-backup-file-names (filename) ;; <compat-tests:file-backup-file-names>
|
||
"Return a list of backup files for FILENAME.
|
||
The list will be sorted by modification time so that the most
|
||
recent files are first."
|
||
;; `make-backup-file-name' will get us the right directory for
|
||
;; ordinary or numeric backups. It might create a directory for
|
||
;; backups as a side-effect, according to `backup-directory-alist'.
|
||
(let* ((filename (file-name-sans-versions
|
||
(make-backup-file-name (expand-file-name filename))))
|
||
(dir (file-name-directory filename))
|
||
files)
|
||
(dolist (file (file-name-all-completions
|
||
(file-name-nondirectory filename) dir))
|
||
(let ((candidate (concat dir file)))
|
||
(when (and (backup-file-name-p candidate)
|
||
(string= (file-name-sans-versions candidate) filename))
|
||
(push candidate files))))
|
||
(sort files #'file-newer-than-file-p)))
|
||
|
||
(compat-defun make-lock-file-name (filename) ;; <compat-tests:make-lock-file-name>
|
||
"Make a lock file name for FILENAME.
|
||
This prepends \".#\" to the non-directory part of FILENAME, and
|
||
doesn't respect `lock-file-name-transforms', as Emacs 28.1 and
|
||
onwards does."
|
||
(expand-file-name
|
||
(concat
|
||
".#" (file-name-nondirectory filename))
|
||
(file-name-directory filename)))
|
||
|
||
;;;; Defined in minibuffer.el
|
||
|
||
(compat-defun format-prompt (prompt default &rest format-args) ;; <compat-tests:format-prompt>
|
||
"Format PROMPT with DEFAULT.
|
||
If FORMAT-ARGS is nil, PROMPT is used as a plain string. If
|
||
FORMAT-ARGS is non-nil, PROMPT is used as a format control
|
||
string, and FORMAT-ARGS are the arguments to be substituted into
|
||
it. See `format' for details.
|
||
|
||
If DEFAULT is a list, the first element is used as the default.
|
||
If not, the element is used as is.
|
||
|
||
If DEFAULT is nil or an empty string, no \"default value\" string
|
||
is included in the return value."
|
||
(concat
|
||
(if (null format-args)
|
||
prompt
|
||
(apply #'format prompt format-args))
|
||
(and default
|
||
(or (not (stringp default))
|
||
(> (length default) 0))
|
||
(format " (default %s)"
|
||
(if (consp default)
|
||
(car default)
|
||
default)))
|
||
": "))
|
||
|
||
;;;; Defined in faces.el
|
||
|
||
(compat-defvar color-luminance-dark-limit 0.325 ;; <compat-tests:color-dark-p>
|
||
"The relative luminance below which a color is considered \"dark\".
|
||
A \"dark\" color in this sense provides better contrast with white
|
||
than with black; see `color-dark-p'.
|
||
This value was determined experimentally."
|
||
:constant t)
|
||
|
||
(compat-defun color-dark-p (rgb) ;; <compat-tests:color-dark-p>
|
||
"Whether RGB is more readable against white than black.
|
||
RGB is a 3-element list (R G B), each component in the range [0,1].
|
||
This predicate can be used both for determining a suitable (black or white)
|
||
contrast color with RGB as background and as foreground."
|
||
(unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)
|
||
(error "RGB components %S not in [0,1]" rgb))
|
||
;; Compute the relative luminance after gamma-correcting (assuming sRGB),
|
||
;; and compare to a cut-off value determined experimentally.
|
||
;; See https://en.wikipedia.org/wiki/Relative_luminance for details.
|
||
(let* ((sr (nth 0 rgb))
|
||
(sg (nth 1 rgb))
|
||
(sb (nth 2 rgb))
|
||
;; Gamma-correct the RGB components to linear values.
|
||
;; Use the power 2.2 as an approximation to sRGB gamma;
|
||
;; it should be good enough for the purpose of this function.
|
||
(r (expt sr 2.2))
|
||
(g (expt sg 2.2))
|
||
(b (expt sb 2.2))
|
||
(y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
|
||
(< y color-luminance-dark-limit)))
|
||
|
||
;;;; Defined in window.el
|
||
|
||
(compat-defmacro with-window-non-dedicated (window &rest body) ;; <compat-tests:with-window-non-dedicated>
|
||
"Evaluate BODY with WINDOW temporarily made non-dedicated.
|
||
If WINDOW is nil, use the selected window. Return the value of
|
||
the last form in BODY."
|
||
(declare (indent 1) (debug t))
|
||
(let ((window-dedicated-sym (gensym))
|
||
(window-sym (gensym)))
|
||
`(let* ((,window-sym (window-normalize-window ,window t))
|
||
(,window-dedicated-sym (window-dedicated-p ,window-sym)))
|
||
(set-window-dedicated-p ,window-sym nil)
|
||
(unwind-protect
|
||
(progn ,@body)
|
||
(set-window-dedicated-p ,window-sym ,window-dedicated-sym)))))
|
||
|
||
(compat-defun count-windows (&optional minibuf all-frames) ;; <compat-tests:count-windows>
|
||
"Handle optional argument ALL-FRAMES."
|
||
:extended t
|
||
(if all-frames
|
||
(let ((sum 0))
|
||
(dolist (frame (frame-list))
|
||
(with-selected-frame frame
|
||
(setq sum (+ (count-windows minibuf) sum))))
|
||
sum)
|
||
(count-windows minibuf)))
|
||
|
||
;;;; Defined in thingatpt.el
|
||
|
||
(compat-defun thing-at-mouse (event thing &optional no-properties) ;; <compat-tests:thing-at-mouse>
|
||
"Return the THING at mouse click.
|
||
Like `thing-at-point', but tries to use the event
|
||
where the mouse button is clicked to find a thing nearby."
|
||
;; No :feature specified, since the function is autoloaded.
|
||
(save-excursion
|
||
(mouse-set-point event)
|
||
(thing-at-point thing no-properties)))
|
||
|
||
(compat-defun bounds-of-thing-at-mouse (event thing) ;; <compat-tests:thing-at-mouse>
|
||
"Determine start and end locations for THING at mouse click given by EVENT.
|
||
Like `bounds-of-thing-at-point', but tries to use the position in EVENT
|
||
where the mouse button is clicked to find the thing nearby."
|
||
;; No :feature specified, since the function is autoloaded.
|
||
(save-excursion
|
||
(mouse-set-point event)
|
||
(bounds-of-thing-at-point thing)))
|
||
|
||
;;;; Defined in mouse.el
|
||
|
||
(compat-defun mark-thing-at-mouse (click thing) ;; <compat-tests:thing-at-mouse>
|
||
"Activate the region around THING found near the mouse CLICK."
|
||
(when-let ((bounds (bounds-of-thing-at-mouse click thing)))
|
||
(goto-char (if mouse-select-region-move-to-beginning
|
||
(car bounds) (cdr bounds)))
|
||
(push-mark (if mouse-select-region-move-to-beginning
|
||
(cdr bounds) (car bounds))
|
||
t 'activate)))
|
||
|
||
;;;; Defined in macroexp.el
|
||
|
||
(compat-defun macroexp-warn-and-return (msg form &optional _category _compile-only _arg) ;; <compat-tests:macroexp-warn-and-return>
|
||
"Return code equivalent to FORM labeled with warning MSG.
|
||
CATEGORY is the category of the warning, like the categories that
|
||
can appear in `byte-compile-warnings'.
|
||
COMPILE-ONLY non-nil means no warning should be emitted if the code
|
||
is executed without being compiled first.
|
||
ARG is a symbol (or a form) giving the source code position for the message.
|
||
It should normally be a symbol with position and it defaults to FORM."
|
||
(macroexp--warn-and-return msg form))
|
||
|
||
(compat-defun macroexp-file-name () ;; <compat-tests:macroexp-file-name>
|
||
"Return the name of the file from which the code comes.
|
||
Returns nil when we do not know.
|
||
A non-nil result is expected to be reliable when called from a macro in order
|
||
to find the file in which the macro's call was found, and it should be
|
||
reliable as well when used at the top-level of a file.
|
||
Other uses risk returning non-nil value that point to the wrong file."
|
||
(let ((file (car (last current-load-list))))
|
||
(or (if (stringp file) file)
|
||
(bound-and-true-p byte-compile-current-file))))
|
||
|
||
;;;; Defined in env.el
|
||
|
||
(compat-defmacro with-environment-variables (variables &rest body) ;; <compat-tests:with-environment-variables>
|
||
"Set VARIABLES in the environent and execute BODY.
|
||
VARIABLES is a list of variable settings of the form (VAR VALUE),
|
||
where VAR is the name of the variable (a string) and VALUE
|
||
is its value (also a string).
|
||
|
||
The previous values will be be restored upon exit."
|
||
(declare (indent 1) (debug (sexp body)))
|
||
(unless (consp variables)
|
||
(error "Invalid VARIABLES: %s" variables))
|
||
`(let ((process-environment (copy-sequence process-environment)))
|
||
,@(mapcar (lambda (elem)
|
||
`(setenv ,(car elem) ,(cadr elem)))
|
||
variables)
|
||
,@body))
|
||
|
||
;;;; Defined in time-data.el
|
||
|
||
(compat-defun decoded-time-period (time) ;; <compat-tests:decoded-time-period>
|
||
"Interpret DECODED as a period and return its length in seconds.
|
||
For computational purposes, years are 365 days long and months
|
||
are 30 days long."
|
||
:feature time-date
|
||
(+ (if (consp (decoded-time-second time))
|
||
(/ (float (car (decoded-time-second time)))
|
||
(cdr (decoded-time-second time)))
|
||
(or (decoded-time-second time) 0))
|
||
(* (or (decoded-time-minute time) 0) 60)
|
||
(* (or (decoded-time-hour time) 0) 60 60)
|
||
(* (or (decoded-time-day time) 0) 60 60 24)
|
||
(* (or (decoded-time-month time) 0) 60 60 24 30)
|
||
(* (or (decoded-time-year time) 0) 60 60 24 365)))
|
||
|
||
;;;; Defined in doc.c
|
||
|
||
(compat-defun text-quoting-style () ;; <compat-tests:text-quoting-style>
|
||
"Return the current effective text quoting style.
|
||
If the variable `text-quoting-style' is `grave', `straight' or
|
||
`curve', just return that value. If it is nil (the default), return
|
||
`grave' if curved quotes cannot be displayed (for instance, on a
|
||
terminal with no support for these characters), otherwise return
|
||
`quote'. Any other value is treated as `grave'.
|
||
|
||
Note that in contrast to the variable `text-quoting-style', this
|
||
function will never return nil."
|
||
(cond
|
||
((memq text-quoting-style '(grave straight curve))
|
||
text-quoting-style)
|
||
((not text-quoting-style) 'grave)
|
||
(t 'curve)))
|
||
|
||
;;;; Defined in button.el
|
||
|
||
;; Obsolete Alias since 29
|
||
(compat-defalias button-buttonize buttonize :obsolete t) ;; <compat-tests:button-buttonize>
|
||
|
||
;;;; Defined in wid-edit.el
|
||
|
||
(compat-guard t ;; <compat-tests:widget-natnum>
|
||
:feature wid-edit
|
||
(define-widget 'natnum 'restricted-sexp
|
||
"A nonnegative integer."
|
||
:tag "Integer (positive)"
|
||
:value 0
|
||
:type-error "This field should contain a nonnegative integer"
|
||
:match-alternatives '(natnump)))
|
||
|
||
(provide 'compat-28)
|
||
;;; compat-28.el ends here
|