update of packages
This commit is contained in:
@@ -1,7 +0,0 @@
|
||||
;;; Directory Local Variables
|
||||
;;; For more information see (info "(emacs) Directory Variables")
|
||||
|
||||
((emacs-lisp-mode
|
||||
(byte-compile-docstring-max-column . 100)
|
||||
(show-trailing-whitespace . t)
|
||||
(indent-tabs-mode . nil)))
|
||||
@@ -1,9 +1,205 @@
|
||||
#+options: toc:nil num:nil
|
||||
#+link: compat https://todo.sr.ht/~pkal/compat/
|
||||
#+link: compat-srht https://todo.sr.ht/~pkal/compat/
|
||||
#+link: compat-gh https://github.com/emacs-compat/compat/issues/
|
||||
#+options: toc:nil num:nil author:nil
|
||||
|
||||
* Release of "Compat" Version 29.1.4.2
|
||||
|
||||
- compat-28: Improve =make-separator-line= visuals on graphic displays.
|
||||
- compat-28: Add =native-comp-available-p=, which always returns nil.
|
||||
- compat-29: Add variable =lisp-directory=.
|
||||
|
||||
(Release <2023-07-30 Sun>)
|
||||
|
||||
* Release of "Compat" Version 29.1.4.1
|
||||
|
||||
- compat-29: Add ~directory-abbrev-apply~.
|
||||
- compat-29: Add ~directory-abbrev-make-regexp~.
|
||||
|
||||
(Release <2023-03-26 Sun>)
|
||||
|
||||
* Release of "Compat" Version 29.1.4.0
|
||||
|
||||
- compat-27: Drop obsolete ~compat-call dired-get-marked-files~.
|
||||
- compat-28: Add support for ~defcustom~ type ~natnum~.
|
||||
- compat-29: Add ~with-restriction~ and ~without-restriction~.
|
||||
- compat-29: Add ~cl-constantly~.
|
||||
- compat-29: Drop ~with-narrowing~ which was renamed to ~with-restriction~.
|
||||
- compat-28: Add support for ~defcustom~ type ~key~.
|
||||
|
||||
(Release <2023-03-05 Sun>)
|
||||
|
||||
* Release of "Compat" Version 29.1.3.4
|
||||
|
||||
- Ensure that ~seq~ is required properly both at compile time and runtime, such
|
||||
that compilation of downstream packages works even if Compat itself is not
|
||||
compiled. Magit uses a complex continuous integration system, where Magit is
|
||||
compiled and tested, while the Compat dependency is not compiled.
|
||||
- compat-28: Add ~process-lines-handling-status~ and ~process-lines-ignore-status~.
|
||||
|
||||
(Release <2023-02-11 Sat>)
|
||||
|
||||
* Release of "Compat" Version 29.1.3.3
|
||||
|
||||
- compat-27: Add ~with-suppressed-warnings~.
|
||||
- compat-29: Add ~cl-with-gensyms~ and ~cl-once-only~.
|
||||
- compat-29: Load ~seq~, which is preloaded on Emacs 29.
|
||||
|
||||
(Release <2023-02-08 Wed>)
|
||||
|
||||
* Release of "Compat" Version 29.1.3.2
|
||||
|
||||
- compat-26: Add ~make-temp-file~ with optional argument TEXT.
|
||||
- compat-27: Mark ~compat-call dired-get-marked-files~ as obsolete. See the
|
||||
section limitations in the Compat manual.
|
||||
- compat-29: Add ~funcall-with-delayed-message~ and ~with-delayed-message~.
|
||||
- compat-29: Add ~ert-with-temp-file~ and ~ert-with-temp-directory~.
|
||||
- compat-29: Add ~set-transient-map~ with optional arguments MESSAGE and TIMEOUT.
|
||||
|
||||
(Release <2023-02-01 Wed>)
|
||||
|
||||
* Release of "Compat" Version 29.1.3.1
|
||||
|
||||
- Fix regression, which prevented loading Compat in interpreted mode. We ensure
|
||||
that Compat works interpreted and byte compiled by running the entire test
|
||||
suite twice in the CI. See https://github.com/magit/magit/issues/4858 for the
|
||||
corresponding Magit issue.
|
||||
- compat-27: Add ~file-name-unquote~.
|
||||
- compat-28: Add ~mark-thing-at-mouse~.
|
||||
- compat-29: Replace ~string-lines~ with version from Emacs 29, support optional
|
||||
KEEP-NEWLINES argument.
|
||||
|
||||
(Release <2023-01-25 Wed>)
|
||||
|
||||
* Release of "Compat" Version 29.1.3.0
|
||||
|
||||
- compat-25: Add ~hash-table-empty-p~.
|
||||
- compat-25: Add ~macroexp-parse-body~ and ~macroexp-quote~.
|
||||
- compat-25: Add ~region-noncontiguous-p~.
|
||||
- compat-25: Add ~save-mark-and-excursion~.
|
||||
- compat-26: Add ~read-answer~.
|
||||
- compat-26: Add ~region-bounds~.
|
||||
- compat-27: Add ~date-ordinal-to-time~.
|
||||
- compat-27: Add ~file-size-human-readable-iec~.
|
||||
- compat-27: Add ~major-mode-suspend~ and ~major-mode-restore~.
|
||||
- compat-27: Add ~make-decoded-time~.
|
||||
- compat-27: Add ~minibuffer-history-value~.
|
||||
- compat-27: Add ~read-char-from-minibuffer~.
|
||||
- compat-27: Add ~ring-resize~.
|
||||
- compat-28: Add ~color-dark-p~.
|
||||
- compat-28: Add ~directory-files-and-attributes~ with COUNT argument.
|
||||
- compat-28: Add ~text-quoting-style~.
|
||||
- compat-28: Add ~with-window-non-dedicated~.
|
||||
- compat-29: Add ~buffer-local-set-state~ and ~buffer-local-restore-state~.
|
||||
- compat-29: Add ~compiled-function-p~.
|
||||
- compat-29: Add ~count-sentences~.
|
||||
- compat-29: Add ~delete-line~.
|
||||
- compat-29: Add ~get-scratch-buffer-create~.
|
||||
- compat-29: Add ~list-of-strings-p~.
|
||||
- compat-29: Add ~plist-get~ generalized variable.
|
||||
- compat-29: Add ~plistp~.
|
||||
- compat-29: Add ~read-multiple-choice~ with LONG-FORM argument.
|
||||
- compat-29: Add ~readablep~.
|
||||
- compat-29: Add ~substitute-quotes~.
|
||||
- compat-29: Add ~use-region-beginning~, ~use-region-end~ and ~use-region-noncontiguous-p~.
|
||||
- compat-29: Add ~with-narrowing~.
|
||||
|
||||
(Release <2023-01-22 Sun>)
|
||||
|
||||
* Release of "Compat" Version 29.1.2.0
|
||||
|
||||
- All compatibility functions are covered by tests!
|
||||
- Add links from compatibility definitions to tests.
|
||||
- BREAKING: Drop JSON parsing support (libjansson API, unused downstream).
|
||||
- BREAKING: Drop ~null-device~ (unused downstream).
|
||||
- BREAKING: Drop ~unlock-buffer~ (unused downstream).
|
||||
- compat-26: Add ~buffer-hash~.
|
||||
- compat-27: Add ~fixnump~ and ~bignump~.
|
||||
- compat-27: Add ~with-minibuffer-selected-window~.
|
||||
- compat-27: Add generalized variables for ~decoded-time-*~.
|
||||
- compat-28: Add ~macroexp-warn-and-return~.
|
||||
- compat-28: Add ~subr-native-elisp-p~.
|
||||
- compat-28: Add ~bounds-of-thing-at-mouse~.
|
||||
- compat-29: Add ~with-buffer-unmodified-if-unchanged~.
|
||||
- compat-29: Fix and test ~define-key~ with REMOVE argument.
|
||||
|
||||
(Release <2023-01-16 Mon>)
|
||||
|
||||
* Release of "Compat" Version 29.1.1.1
|
||||
|
||||
- Add tests, 167 out of 203 definitions tested (82%).
|
||||
- compat-25: Improve algorithmic complexity of ~sort~.
|
||||
- compat-28: Add ~make-separator-line~.
|
||||
- compat-29: Minor fixes to ~keymap-*~ functions.
|
||||
- compat-29: Add ~with-memoization~.
|
||||
- compat-29: Add ~buttonize~ and ~buttonize-region~.
|
||||
|
||||
(Release <2023-01-14 Sat>)
|
||||
|
||||
* Release of "Compat" Version 29.1.1.0
|
||||
|
||||
- The macros in ~compat-macs.el~ have been rewritten and simplified. The
|
||||
refactoring allows to further refine the criteria under which compatibility
|
||||
aliases, functions, macros and variables are installed.
|
||||
- Remove deprecated, prefixed compatibility functions.
|
||||
- Remove deprecated features ~compat-help~, ~compat-font-lock~ and ~compat-24~.
|
||||
- Compat uses runtime checks (~boundp~, ~fboundp~) to ensure that existing
|
||||
definitions are never overridden, when Compat is loaded on a newer Emacs than
|
||||
it was compiled on.
|
||||
- Compat compiles without byte compilation warnings on all supported Emacs
|
||||
versions. Warnings are treated as errors in the test suite.
|
||||
- Compat takes great care to remove unneeded definitions at compile time. On
|
||||
recent Emacs 29 the byte compiled files are empty and not loaded, such that
|
||||
Compat does not any cost to the Emacs process.
|
||||
- compat-26: Fix and test ~image-property~ setter.
|
||||
- compat-26: Fix and test ~read-multiple-choice~.
|
||||
- compat-28: Fix and test ~with-existing-directory~.
|
||||
- compat-28: Drop obsolete function ~make-directory-autoloads~.
|
||||
- compat-29: Drop broken functions ~string-pixel-width~ and
|
||||
~buffer-text-pixel-size~. These functions had poor performance which lead to a
|
||||
downstream issue in the doom-modeline package. If a more efficient solution is
|
||||
possible, the function will be added back. See [[compat-gh:8]] for the bug report.
|
||||
- compat-29: Drop broken function ~string-limit~.
|
||||
- compat-29: Drop broken macro ~with-buffer-unmodified-if-unchanged~, which relied
|
||||
on ~buffer-hash~ which does not exist on all supported Emacs versions.
|
||||
- compat-29: Add ~pos-bol~ and ~pos-eol~.
|
||||
|
||||
(Release <2023-01-07 Sat>)
|
||||
|
||||
* Release of "Compat" Version 29.1.0.1
|
||||
|
||||
- Add multiple new tests for existing APIs.
|
||||
- Fix bugs in compatibility functions: ~setq-local~, ~proper-list-p, prop-match-p~,
|
||||
~file-name-concat~, ~replace-regexp-in-region~, ~replace-string-in-region~.
|
||||
- Add new Emacs 29 APIs. Some of them are still untested and may change. If you
|
||||
intend to use an Emacs 29 API please be careful and if possible contribute
|
||||
test cases. All untested functions are marked in the Compat code. Over time
|
||||
tests for all functions will be added gradually.
|
||||
- Add the macros ~compat-call~ and ~compat-function~ to call compatibility
|
||||
functions. Since Compat avoids overwriting already existing functions, we must
|
||||
define separate compatibility function definitions for functions which changed
|
||||
their calling convention or behavior. These compatibility definitions can be
|
||||
looked up using ~compat-function~ and called with ~compat-call~. For example ~assoc~
|
||||
can be called with a ~TESTFN~ since Emacs 26. In Emacs 25 and older the calling
|
||||
convention was ~(assoc KEY ALIST)~. In order to use the new calling convention
|
||||
you can use ~(compat-call assoc KEY ALIST TESTFN)~.
|
||||
- Deprecate all ~compat-*~ prefixed functions. Instead use the aforementioned
|
||||
~compat-call~ or ~compat-function~ macros.
|
||||
- Deprecate ~compat-help.el~ and ~compat-font-lock.el.~
|
||||
- Development moved to GitHub.
|
||||
- BREAKING: Drop broken function ~func-arity~. Using ~func-arity~ is generally
|
||||
discouraged and the function is hard to implement properly due to all the
|
||||
various function types. There it is unlikely that the function will get
|
||||
reintroduced in Compat.
|
||||
- BREAKING: Drop broken function ~directory-files-recursively~. In case you need
|
||||
this function, a patch including tests is welcome.
|
||||
- BREAKING: Drop support for Emacs 24.3. Emacs 24.4 is required now. In case you
|
||||
still need Emacs 24.3 support, you can rely on Compat 28.1.2.2.
|
||||
|
||||
(Release <2023-01-05 Thu>)
|
||||
|
||||
* Release of "Compat" Version 28.1.2.2
|
||||
|
||||
This is a minor release that hopes to address [[compat:7]].
|
||||
This is a minor release that hopes to address [[compat-srht:7]].
|
||||
|
||||
(Release <2022-08-25 Thu>)
|
||||
|
||||
@@ -25,7 +221,7 @@ include much more documentation that had been the case previously.
|
||||
|
||||
The main change of this release has been the major simplification of
|
||||
Compat's initialisation system, improving the situation around issues
|
||||
people had been reporting ([[compat:4]], once again) with unconventional
|
||||
people had been reporting ([[compat-srht:4]], once again) with unconventional
|
||||
or unpopular packaging systems.
|
||||
|
||||
In addition to this, the following functional changes have been made:
|
||||
@@ -42,7 +238,7 @@ Minor improvements to manual are also part of this release.
|
||||
|
||||
This release just contains a hot-fix for an issue introduced in the
|
||||
last version, where compat.el raises an error during byte compilation.
|
||||
See [[compat:4]].
|
||||
See [[compat-srht:4]].
|
||||
|
||||
(Release <2022-06-19 Sun>)
|
||||
|
||||
@@ -62,7 +258,7 @@ Two main changes have necessitated a new patch release:
|
||||
|
||||
This is a minor release fixing a bug in =json-serialize=, that could
|
||||
cause unintended side-effects, not related to packages using Compat
|
||||
directly (see [[compat:2]]).
|
||||
directly (see [[compat-srht:2]]).
|
||||
|
||||
(Released <2022-05-05 Thu>)
|
||||
|
||||
@@ -98,11 +294,4 @@ as some of these changes a functional. These include:
|
||||
- Handling out-of-directory byte compilation better.
|
||||
- Fixing the usage and edge-cases of =and-let*=.
|
||||
|
||||
Furthermore a bug tracker was added: https://todo.sr.ht/~pkal/compat,
|
||||
which is the preferred way to report issues or feature requests.
|
||||
General problems, questions, etc. are still better discussed on the
|
||||
development mailing list: https://lists.sr.ht/~pkal/compat-devel.
|
||||
|
||||
(Released <2022-04-22 Fri>)
|
||||
|
||||
|
||||
|
||||
@@ -1,495 +0,0 @@
|
||||
;;; compat-24.el --- Compatibility Layer for Emacs 24.4 -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
|
||||
;; URL: https://git.sr.ht/~pkal/compat/
|
||||
;; Keywords: lisp
|
||||
|
||||
;; 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:
|
||||
|
||||
;; Find here the functionality added in Emacs 24.4, needed by older
|
||||
;; versions.
|
||||
;;
|
||||
;; Only load this library if you need to use one of the following
|
||||
;; functions:
|
||||
;;
|
||||
;; - `compat-='
|
||||
;; - `compat-<'
|
||||
;; - `compat->'
|
||||
;; - `compat-<='
|
||||
;; - `compat->='
|
||||
;; - `split-string'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'compat-macs "compat-macs.el")
|
||||
|
||||
(compat-declare-version "24.4")
|
||||
|
||||
;;;; Defined in data.c
|
||||
|
||||
(compat-defun = (number-or-marker &rest numbers-or-markers)
|
||||
"Handle multiple arguments."
|
||||
:prefix t
|
||||
(catch 'fail
|
||||
(while numbers-or-markers
|
||||
(unless (= number-or-marker (car numbers-or-markers))
|
||||
(throw 'fail nil))
|
||||
(setq number-or-marker (pop numbers-or-markers)))
|
||||
t))
|
||||
|
||||
(compat-defun < (number-or-marker &rest numbers-or-markers)
|
||||
"Handle multiple arguments."
|
||||
:prefix t
|
||||
(catch 'fail
|
||||
(while numbers-or-markers
|
||||
(unless (< number-or-marker (car numbers-or-markers))
|
||||
(throw 'fail nil))
|
||||
(setq number-or-marker (pop numbers-or-markers)))
|
||||
t))
|
||||
|
||||
(compat-defun > (number-or-marker &rest numbers-or-markers)
|
||||
"Handle multiple arguments."
|
||||
:prefix t
|
||||
(catch 'fail
|
||||
(while numbers-or-markers
|
||||
(unless (> number-or-marker (car numbers-or-markers))
|
||||
(throw 'fail nil))
|
||||
(setq number-or-marker (pop numbers-or-markers)))
|
||||
t))
|
||||
|
||||
(compat-defun <= (number-or-marker &rest numbers-or-markers)
|
||||
"Handle multiple arguments."
|
||||
:prefix t
|
||||
(catch 'fail
|
||||
(while numbers-or-markers
|
||||
(unless (<= number-or-marker (car numbers-or-markers))
|
||||
(throw 'fail nil))
|
||||
(setq number-or-marker (pop numbers-or-markers)))
|
||||
t))
|
||||
|
||||
(compat-defun >= (number-or-marker &rest numbers-or-markers)
|
||||
"Handle multiple arguments."
|
||||
:prefix t
|
||||
(catch 'fail
|
||||
(while numbers-or-markers
|
||||
(unless (>= number-or-marker (pop numbers-or-markers))
|
||||
(throw 'fail nil)))
|
||||
t))
|
||||
|
||||
(compat-defun bool-vector-exclusive-or (a b &optional c)
|
||||
"Return A ^ B, bitwise exclusive or.
|
||||
If optional third argument C is given, store result into C.
|
||||
A, B, and C must be bool vectors of the same length.
|
||||
Return the destination vector if it changed or nil otherwise."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(unless (bool-vector-p b)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p b)))
|
||||
(unless (or (null c) (bool-vector-p c))
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p c)))
|
||||
(when (/= (length a) (length b))
|
||||
(signal 'wrong-length-argument (list (length a) (length b))))
|
||||
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
|
||||
(when (/= (length a) (length dest))
|
||||
(signal 'wrong-length-argument (list (length a) (length dest))))
|
||||
(dotimes (i (length dest))
|
||||
(let ((val (not (eq (aref a i) (aref b i)))))
|
||||
(unless (eq val (aref dest i))
|
||||
(setq changed t))
|
||||
(aset dest i val)))
|
||||
(if c (and changed c) dest)))
|
||||
|
||||
(compat-defun bool-vector-union (a b &optional c)
|
||||
"Return A | B, bitwise or.
|
||||
If optional third argument C is given, store result into C.
|
||||
A, B, and C must be bool vectors of the same length.
|
||||
Return the destination vector if it changed or nil otherwise."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(unless (bool-vector-p b)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p b)))
|
||||
(unless (or (null c) (bool-vector-p c))
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p c)))
|
||||
(when (/= (length a) (length b))
|
||||
(signal 'wrong-length-argument (list (length a) (length b))))
|
||||
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
|
||||
(when (/= (length a) (length dest))
|
||||
(signal 'wrong-length-argument (list (length a) (length dest))))
|
||||
(dotimes (i (length dest))
|
||||
(let ((val (or (aref a i) (aref b i))))
|
||||
(unless (eq val (aref dest i))
|
||||
(setq changed t))
|
||||
(aset dest i val)))
|
||||
(if c (and changed c) dest)))
|
||||
|
||||
(compat-defun bool-vector-intersection (a b &optional c)
|
||||
"Return A & B, bitwise and.
|
||||
If optional third argument C is given, store result into C.
|
||||
A, B, and C must be bool vectors of the same length.
|
||||
Return the destination vector if it changed or nil otherwise."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(unless (bool-vector-p b)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p b)))
|
||||
(unless (or (null c) (bool-vector-p c))
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p c)))
|
||||
(when (/= (length a) (length b))
|
||||
(signal 'wrong-length-argument (list (length a) (length b))))
|
||||
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
|
||||
(when (/= (length a) (length dest))
|
||||
(signal 'wrong-length-argument (list (length a) (length dest))))
|
||||
(dotimes (i (length dest))
|
||||
(let ((val (and (aref a i) (aref b i))))
|
||||
(unless (eq val (aref dest i))
|
||||
(setq changed t))
|
||||
(aset dest i val)))
|
||||
(if c (and changed c) dest)))
|
||||
|
||||
(compat-defun bool-vector-set-difference (a b &optional c)
|
||||
"Return A &~ B, set difference.
|
||||
If optional third argument C is given, store result into C.
|
||||
A, B, and C must be bool vectors of the same length.
|
||||
Return the destination vector if it changed or nil otherwise."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(unless (bool-vector-p b)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p b)))
|
||||
(unless (or (null c) (bool-vector-p c))
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p c)))
|
||||
(when (/= (length a) (length b))
|
||||
(signal 'wrong-length-argument (list (length a) (length b))))
|
||||
(let ((dest (or c (make-bool-vector (length a) nil))) changed)
|
||||
(when (/= (length a) (length dest))
|
||||
(signal 'wrong-length-argument (list (length a) (length dest))))
|
||||
(dotimes (i (length dest))
|
||||
(let ((val (and (aref a i) (not (aref b i)))))
|
||||
(unless (eq val (aref dest i))
|
||||
(setq changed t))
|
||||
(aset dest i val)))
|
||||
(if c (and changed c) dest)))
|
||||
|
||||
(compat-defun bool-vector-not (a &optional b)
|
||||
"Compute ~A, set complement.
|
||||
If optional second argument B is given, store result into B.
|
||||
A and B must be bool vectors of the same length.
|
||||
Return the destination vector."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(unless (or (null b) (bool-vector-p b))
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p b)))
|
||||
(let ((dest (or b (make-bool-vector (length a) nil))))
|
||||
(when (/= (length a) (length dest))
|
||||
(signal 'wrong-length-argument (list (length a) (length dest))))
|
||||
(dotimes (i (length dest))
|
||||
(aset dest i (not (aref a i))))
|
||||
dest))
|
||||
|
||||
(compat-defun bool-vector-subsetp (a b)
|
||||
"Return t if every t value in A is also t in B, nil otherwise.
|
||||
A and B must be bool vectors of the same length."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(unless (bool-vector-p b)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p b)))
|
||||
(when (/= (length a) (length b))
|
||||
(signal 'wrong-length-argument (list (length a) (length b))))
|
||||
(catch 'not-subset
|
||||
(dotimes (i (length a))
|
||||
(when (if (aref a i) (not (aref b i)) nil)
|
||||
(throw 'not-subset nil)))
|
||||
t))
|
||||
|
||||
(compat-defun bool-vector-count-consecutive (a b i)
|
||||
"Count how many consecutive elements in A equal B starting at I.
|
||||
A is a bool vector, B is t or nil, and I is an index into A."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(setq b (and b t)) ;normalise to nil or t
|
||||
(unless (< i (length a))
|
||||
(signal 'args-out-of-range (list a i)))
|
||||
(let ((len (length a)) (n i))
|
||||
(while (and (< i len) (eq (aref a i) b))
|
||||
(setq i (1+ i)))
|
||||
(- i n)))
|
||||
|
||||
(compat-defun bool-vector-count-population (a)
|
||||
"Count how many elements in A are t.
|
||||
A is a bool vector. To count A's nil elements, subtract the
|
||||
return value from A's length."
|
||||
(unless (bool-vector-p a)
|
||||
(signal 'wrong-type-argument (list 'bool-vector-p a)))
|
||||
(let ((n 0))
|
||||
(dotimes (i (length a))
|
||||
(when (aref a i)
|
||||
(setq n (1+ n))))
|
||||
n))
|
||||
|
||||
;;;; Defined in subr.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defmacro with-eval-after-load (file &rest body)
|
||||
"Execute BODY after FILE is loaded.
|
||||
FILE is normally a feature name, but it can also be a file name,
|
||||
in case that file does not provide any feature. See `eval-after-load'
|
||||
for more details about the different forms of FILE and their semantics."
|
||||
(declare (indent 1) (debug (form def-body)))
|
||||
;; See https://nullprogram.com/blog/2018/02/22/ on how
|
||||
;; `eval-after-load' is used to preserve compatibility with 24.3.
|
||||
`(eval-after-load ,file `(funcall ',,`(lambda () ,@body))))
|
||||
|
||||
(compat-defun special-form-p (object)
|
||||
"Non-nil if and only if OBJECT is a special form."
|
||||
(if (and (symbolp object) (fboundp object))
|
||||
(setq object (condition-case nil
|
||||
(indirect-function object)
|
||||
(void-function nil))))
|
||||
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
|
||||
|
||||
(compat-defun macrop (object)
|
||||
"Non-nil if and only if OBJECT is a macro."
|
||||
(let ((def (condition-case nil
|
||||
(indirect-function object)
|
||||
(void-function nil))))
|
||||
(when (consp def)
|
||||
(or (eq 'macro (car def))
|
||||
(and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
|
||||
|
||||
(compat-defun string-suffix-p (suffix string &optional ignore-case)
|
||||
"Return non-nil if SUFFIX is a suffix of STRING.
|
||||
If IGNORE-CASE is non-nil, the comparison is done without paying
|
||||
attention to case differences."
|
||||
(let ((start-pos (- (length string) (length suffix))))
|
||||
(and (>= start-pos 0)
|
||||
(eq t (compare-strings suffix nil nil
|
||||
string start-pos nil ignore-case)))))
|
||||
|
||||
(compat-defun split-string (string &optional separators omit-nulls trim)
|
||||
"Extend `split-string' by a TRIM argument.
|
||||
The remaining arguments STRING, SEPARATORS and OMIT-NULLS are
|
||||
handled just as with `split-string'."
|
||||
:prefix t
|
||||
(let* ((token (split-string string separators omit-nulls))
|
||||
(trimmed (if trim
|
||||
(mapcar
|
||||
(lambda (token)
|
||||
(when (string-match (concat "\\`" trim) token)
|
||||
(setq token (substring token (match-end 0))))
|
||||
(when (string-match (concat trim "\\'") token)
|
||||
(setq token (substring token 0 (match-beginning 0))))
|
||||
token)
|
||||
token)
|
||||
token)))
|
||||
(if omit-nulls (delete "" trimmed) trimmed)))
|
||||
|
||||
(compat-defun delete-consecutive-dups (list &optional circular)
|
||||
"Destructively remove `equal' consecutive duplicates from LIST.
|
||||
First and last elements are considered consecutive if CIRCULAR is
|
||||
non-nil."
|
||||
(let ((tail list) last)
|
||||
(while (cdr tail)
|
||||
(if (equal (car tail) (cadr tail))
|
||||
(setcdr tail (cddr tail))
|
||||
(setq last tail
|
||||
tail (cdr tail))))
|
||||
(if (and circular
|
||||
last
|
||||
(equal (car tail) (car list)))
|
||||
(setcdr last nil)))
|
||||
list)
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun define-error (name message &optional parent)
|
||||
"Define NAME as a new error signal.
|
||||
MESSAGE is a string that will be output to the echo area if such an error
|
||||
is signaled without being caught by a `condition-case'.
|
||||
PARENT is either a signal or a list of signals from which it inherits.
|
||||
Defaults to `error'."
|
||||
(unless parent (setq parent 'error))
|
||||
(let ((conditions
|
||||
(if (consp parent)
|
||||
(apply #'append
|
||||
(mapcar (lambda (parent)
|
||||
(cons parent
|
||||
(or (get parent 'error-conditions)
|
||||
(error "Unknown signal `%s'" parent))))
|
||||
parent))
|
||||
(cons parent (get parent 'error-conditions)))))
|
||||
(put name 'error-conditions
|
||||
(delete-dups (copy-sequence (cons name conditions))))
|
||||
(when message (put name 'error-message message))))
|
||||
|
||||
;;;; Defined in minibuffer.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun completion-table-with-cache (fun &optional ignore-case)
|
||||
"Create dynamic completion table from function FUN, with cache.
|
||||
This is a wrapper for `completion-table-dynamic' that saves the last
|
||||
argument-result pair from FUN, so that several lookups with the
|
||||
same argument (or with an argument that starts with the first one)
|
||||
only need to call FUN once. This can be useful when FUN performs a
|
||||
relatively slow operation, such as calling an external process.
|
||||
|
||||
When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
|
||||
(let* (last-arg last-result
|
||||
(new-fun
|
||||
(lambda (arg)
|
||||
(if (and last-arg (string-prefix-p last-arg arg ignore-case))
|
||||
last-result
|
||||
(prog1
|
||||
(setq last-result (funcall fun arg))
|
||||
(setq last-arg arg))))))
|
||||
(completion-table-dynamic new-fun)))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun completion-table-merge (&rest tables)
|
||||
"Create a completion table that collects completions from all TABLES."
|
||||
(lambda (string pred action)
|
||||
(cond
|
||||
((null action)
|
||||
(let ((retvals (mapcar (lambda (table)
|
||||
(try-completion string table pred))
|
||||
tables)))
|
||||
(if (member string retvals)
|
||||
string
|
||||
(try-completion string
|
||||
(mapcar (lambda (value)
|
||||
(if (eq value t) string value))
|
||||
(delq nil retvals))
|
||||
pred))))
|
||||
((eq action t)
|
||||
(apply #'append (mapcar (lambda (table)
|
||||
(all-completions string table pred))
|
||||
tables)))
|
||||
(t
|
||||
(completion--some (lambda (table)
|
||||
(complete-with-action action table string pred))
|
||||
tables)))))
|
||||
|
||||
;;;; Defined in subr-x.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-advise require (feature &rest args)
|
||||
"Allow for Emacs 24.x to require the inexistent FEATURE subr-x."
|
||||
;; As the compatibility advise around `require` is more a hack than
|
||||
;; of of actual value, the highlighting is suppressed.
|
||||
:no-highlight t
|
||||
(if (eq feature 'subr-x)
|
||||
(let ((entry (assq feature after-load-alist)))
|
||||
(let ((load-file-name nil))
|
||||
(dolist (form (cdr entry))
|
||||
(funcall (eval form t)))))
|
||||
(apply oldfun feature args)))
|
||||
|
||||
(compat-defun hash-table-keys (hash-table)
|
||||
"Return a list of keys in HASH-TABLE."
|
||||
(let (values)
|
||||
(maphash
|
||||
(lambda (k _v) (push k values))
|
||||
hash-table)
|
||||
values))
|
||||
|
||||
(compat-defun hash-table-values (hash-table)
|
||||
"Return a list of values in HASH-TABLE."
|
||||
(let (values)
|
||||
(maphash
|
||||
(lambda (_k v) (push v values))
|
||||
hash-table)
|
||||
values))
|
||||
|
||||
(compat-defun string-empty-p (string)
|
||||
"Check whether STRING is empty."
|
||||
(string= string ""))
|
||||
|
||||
(compat-defun string-join (strings &optional separator)
|
||||
"Join all STRINGS using SEPARATOR.
|
||||
Optional argument SEPARATOR must be a string, a vector, or a list of
|
||||
characters; nil stands for the empty string."
|
||||
(mapconcat #'identity strings separator))
|
||||
|
||||
(compat-defun string-blank-p (string)
|
||||
"Check whether STRING is either empty or only whitespace.
|
||||
The following characters count as whitespace here: space, tab, newline and
|
||||
carriage return."
|
||||
(string-match-p "\\`[ \t\n\r]*\\'" string))
|
||||
|
||||
(compat-defun string-remove-prefix (prefix string)
|
||||
"Remove PREFIX from STRING if present."
|
||||
(if (string-prefix-p prefix string)
|
||||
(substring string (length prefix))
|
||||
string))
|
||||
|
||||
(compat-defun string-remove-suffix (suffix string)
|
||||
"Remove SUFFIX from STRING if present."
|
||||
(if (string-suffix-p suffix string)
|
||||
(substring string 0 (- (length string) (length suffix)))
|
||||
string))
|
||||
|
||||
;;;; Defined in faces.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun face-spec-set (face spec &optional spec-type)
|
||||
"Set the FACE's spec SPEC, define FACE, and recalculate its attributes.
|
||||
See `defface' for the format of SPEC.
|
||||
|
||||
The appearance of each face is controlled by its specs (set via
|
||||
this function), and by the internal frame-specific face
|
||||
attributes (set via `set-face-attribute').
|
||||
|
||||
This function also defines FACE as a valid face name if it is not
|
||||
already one, and (re)calculates its attributes on existing
|
||||
frames.
|
||||
|
||||
The optional argument SPEC-TYPE determines which spec to set:
|
||||
nil, omitted or `face-override-spec' means the override spec,
|
||||
which overrides all the other types of spec mentioned below
|
||||
(this is usually what you want if calling this function
|
||||
outside of Custom code);
|
||||
`customized-face' or `saved-face' means the customized spec or
|
||||
the saved custom spec;
|
||||
`face-defface-spec' means the default spec
|
||||
(usually set only via `defface');
|
||||
`reset' means to ignore SPEC, but clear the `customized-face'
|
||||
and `face-override-spec' specs;
|
||||
Any other value means not to set any spec, but to run the
|
||||
function for defining FACE and recalculating its attributes."
|
||||
(if (get face 'face-alias)
|
||||
(setq face (get face 'face-alias)))
|
||||
;; Save SPEC to the relevant symbol property.
|
||||
(unless spec-type
|
||||
(setq spec-type 'face-override-spec))
|
||||
(if (memq spec-type '(face-defface-spec face-override-spec
|
||||
customized-face saved-face))
|
||||
(put face spec-type spec))
|
||||
(if (memq spec-type '(reset saved-face))
|
||||
(put face 'customized-face nil))
|
||||
;; Setting the face spec via Custom empties out any override spec,
|
||||
;; similar to how setting a variable via Custom changes its values.
|
||||
(if (memq spec-type '(customized-face saved-face reset))
|
||||
(put face 'face-override-spec nil))
|
||||
;; If we reset the face based on its custom spec, it is unmodified
|
||||
;; as far as Custom is concerned.
|
||||
(unless (eq face 'face-override-spec)
|
||||
(put face 'face-modified nil))
|
||||
;; Initialize the face if it does not exist, then recalculate.
|
||||
(make-empty-face face)
|
||||
(dolist (frame (frame-list))
|
||||
(face-spec-recalc face frame)))
|
||||
|
||||
(compat--inhibit-prefixed (provide 'compat-24))
|
||||
;;; compat-24.el ends here
|
||||
@@ -1,11 +1,6 @@
|
||||
;;; compat-25.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*-
|
||||
;;; compat-25.el --- Functionality added in Emacs 25.1 -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
|
||||
;; URL: https://git.sr.ht/~pkal/compat/
|
||||
;; Keywords: lisp
|
||||
;; 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
|
||||
@@ -22,23 +17,17 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Find here the functionality added in Emacs 25.1, needed by older
|
||||
;; versions.
|
||||
;;
|
||||
;; Only load this library if you need to use one of the following
|
||||
;; functions:
|
||||
;;
|
||||
;; - `compat-sort'
|
||||
;; Functionality added in Emacs 25.1, needed by older Emacs versions.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'compat-macs "compat-macs.el")
|
||||
(eval-when-compile (load "compat-macs.el" nil t t))
|
||||
|
||||
(compat-declare-version "25.1")
|
||||
(compat-version "25.1")
|
||||
|
||||
;;;; Defined in alloc.c
|
||||
|
||||
(compat-defun bool-vector (&rest objects)
|
||||
(compat-defun bool-vector (&rest objects) ;; <compat-tests:bool-vector>
|
||||
"Return a new bool-vector with specified arguments as elements.
|
||||
Allows any number of arguments, including zero.
|
||||
usage: (bool-vector &rest OBJECTS)"
|
||||
@@ -53,53 +42,77 @@ usage: (bool-vector &rest OBJECTS)"
|
||||
|
||||
;;;; Defined in fns.c
|
||||
|
||||
(compat-defun sort (seq predicate)
|
||||
"Extend `sort' to sort SEQ as a vector."
|
||||
:prefix t
|
||||
(compat-defun sort (seq predicate) ;; <compat-tests:sort>
|
||||
"Handle vector SEQ."
|
||||
:extended t
|
||||
(cond
|
||||
((listp seq)
|
||||
(sort seq predicate))
|
||||
((vectorp seq)
|
||||
(let ((cseq (sort (append seq nil) predicate)))
|
||||
(dotimes (i (length cseq))
|
||||
(setf (aref seq i) (nth i cseq)))
|
||||
(apply #'vector cseq)))
|
||||
(let* ((list (sort (append seq nil) predicate))
|
||||
(p list) (i 0))
|
||||
(while p
|
||||
(aset seq i (car p))
|
||||
(setq i (1+ i) p (cdr p)))
|
||||
(apply #'vector list)))
|
||||
((signal 'wrong-type-argument 'list-or-vector-p))))
|
||||
|
||||
;;;; Defined in editfns.c
|
||||
|
||||
(compat-defun format-message (string &rest objects)
|
||||
"Format a string out of a format-string and arguments.
|
||||
The first argument is a format control string.
|
||||
The other arguments are substituted into it to make the result, a string.
|
||||
|
||||
This implementation is equivalent to `format'."
|
||||
(apply #'format string objects))
|
||||
|
||||
;;;; Defined in minibuf.c
|
||||
|
||||
;; TODO advise read-buffer to handle 4th argument
|
||||
(compat-defalias format-message format) ;; <compat-tests:format-message>
|
||||
|
||||
;;;; Defined in fileio.c
|
||||
|
||||
(compat-defun directory-name-p (name)
|
||||
(compat-defun directory-name-p (name) ;; <compat-tests:directory-name-p>
|
||||
"Return non-nil if NAME ends with a directory separator character."
|
||||
:realname compat--directory-name-p
|
||||
(eq (eval-when-compile
|
||||
(if (memq system-type '(cygwin windows-nt ms-dos))
|
||||
?\\ ?/))
|
||||
(aref name (1- (length name)))))
|
||||
|
||||
;;;; Defined in doc.c
|
||||
|
||||
(compat-defvar text-quoting-style nil ;; <compat-tests:text-quoting-style>
|
||||
"Style to use for single quotes in help and messages.
|
||||
|
||||
The value of this variable determines substitution of grave accents
|
||||
and apostrophes in help output (but not for display of Info
|
||||
manuals) and in functions like `message' and `format-message', but not
|
||||
in `format'.
|
||||
|
||||
The value should be one of these symbols:
|
||||
`curve': quote with curved single quotes ‘like this’.
|
||||
`straight': quote with straight apostrophes \\='like this\\='.
|
||||
`grave': quote with grave accent and apostrophe \\=`like this\\=';
|
||||
i.e., do not alter the original quote marks.
|
||||
nil: like `curve' if curved single quotes are displayable,
|
||||
and like `grave' otherwise. This is the default.
|
||||
|
||||
You should never read the value of this variable directly from a Lisp
|
||||
program. Use the function `text-quoting-style' instead, as that will
|
||||
compute the correct value for the current terminal in the nil case.")
|
||||
|
||||
;;;; Defined in simple.el
|
||||
|
||||
;; `save-excursion' behaved like `save-mark-and-excursion' before 25.1.
|
||||
(compat-defalias save-mark-and-excursion save-excursion) ;; <compat-tests:save-mark-and-excursion>
|
||||
|
||||
(declare-function region-bounds nil) ;; Defined in compat-26.el
|
||||
(compat-defun region-noncontiguous-p () ;; <compat-tests:region-noncontiguous-p>
|
||||
"Return non-nil if the region contains several pieces.
|
||||
An example is a rectangular region handled as a list of
|
||||
separate contiguous regions for each line."
|
||||
(let ((bounds (region-bounds))) (and (cdr bounds) bounds)))
|
||||
|
||||
;;;; Defined in subr.el
|
||||
|
||||
(compat-defun string-greaterp (string1 string2)
|
||||
(compat-defun string-greaterp (string1 string2) ;; <compat-tests:string-greaterp>
|
||||
"Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
|
||||
Case is significant.
|
||||
Symbols are also allowed; their print names are used instead."
|
||||
(string-lessp string2 string1))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defmacro with-file-modes (modes &rest body)
|
||||
(compat-defmacro with-file-modes (modes &rest body) ;; <compat-tests:with-file-modes>
|
||||
"Execute BODY with default file permissions temporarily set to MODES.
|
||||
MODES is as for `set-default-file-modes'."
|
||||
(declare (indent 1) (debug t))
|
||||
@@ -111,28 +124,7 @@ MODES is as for `set-default-file-modes'."
|
||||
,@body)
|
||||
(set-default-file-modes ,umask)))))
|
||||
|
||||
(compat-defun alist-get (key alist &optional default remove testfn)
|
||||
"Find the first element of ALIST whose `car' equals KEY and return its `cdr'.
|
||||
If KEY is not found in ALIST, return DEFAULT.
|
||||
Equality with KEY is tested by TESTFN, defaulting to `eq'."
|
||||
:realname compat--alist-get-full-elisp
|
||||
(ignore remove)
|
||||
(let (entry)
|
||||
(cond
|
||||
((or (null testfn) (eq testfn 'eq))
|
||||
(setq entry (assq key alist)))
|
||||
((eq testfn 'equal)
|
||||
(setq entry (assoc key alist)))
|
||||
((catch 'found
|
||||
(dolist (ent alist)
|
||||
(when (and (consp ent) (funcall testfn (car ent) key))
|
||||
(throw 'found (setq entry ent))))
|
||||
default)))
|
||||
(if entry (cdr entry) default)))
|
||||
|
||||
;;;; Defined in subr-x.el
|
||||
|
||||
(compat-defmacro if-let (spec then &rest else)
|
||||
(compat-defmacro if-let (spec then &rest else) ;; <compat-tests:if-let>
|
||||
"Bind variables according to SPEC and evaluate THEN or ELSE.
|
||||
Evaluate each binding in turn, as in `let*', stopping if a
|
||||
binding value is nil. If all are non-nil return the value of
|
||||
@@ -148,29 +140,40 @@ SYMBOL is checked for nil.
|
||||
As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING)
|
||||
like \((SYMBOL SOMETHING)). This exists for backward compatibility
|
||||
with an old syntax that accepted only one binding."
|
||||
:realname compat--if-let
|
||||
:feature 'subr-x
|
||||
(declare (indent 2)
|
||||
(debug ([&or (symbolp form)
|
||||
(&rest [&or symbolp (symbolp form) (form)])]
|
||||
body)))
|
||||
(when (and (<= (length spec) 2)
|
||||
(not (listp (car spec))))
|
||||
(when (and (<= (length spec) 2) (not (listp (car spec))))
|
||||
;; Adjust the single binding case
|
||||
(setq spec (list spec)))
|
||||
`(compat--if-let* ,spec ,then ,(macroexp-progn else)))
|
||||
(let ((empty (make-symbol "s"))
|
||||
(last t) list)
|
||||
(dolist (var spec)
|
||||
(push `(,(if (cdr var) (car var) empty)
|
||||
(and ,last ,(if (cdr var) (cadr var) (car var))))
|
||||
list)
|
||||
(when (or (cdr var) (consp (car var)))
|
||||
(setq last (caar list))))
|
||||
`(let* ,(nreverse list)
|
||||
(if ,(caar list) ,then ,@else))))
|
||||
|
||||
(compat-defmacro when-let (spec &rest body)
|
||||
(compat-defmacro when-let (spec &rest body) ;; <compat-tests:when-let>
|
||||
"Bind variables according to SPEC and conditionally evaluate BODY.
|
||||
Evaluate each binding in turn, stopping if a binding value is nil.
|
||||
If all are non-nil, return the value of the last form in BODY.
|
||||
|
||||
The variable list SPEC is the same as in `if-let'."
|
||||
:feature 'subr-x
|
||||
(declare (indent 1) (debug if-let))
|
||||
`(compat--if-let ,spec ,(macroexp-progn body)))
|
||||
(list 'if-let spec (macroexp-progn body)))
|
||||
|
||||
(compat-defmacro thread-first (&rest forms)
|
||||
;;;; Defined in subr-x.el
|
||||
|
||||
(compat-defun hash-table-empty-p (hash-table) ;; <compat-tests:hash-table-empty-p>
|
||||
"Check whether HASH-TABLE is empty (has 0 elements)."
|
||||
(zerop (hash-table-count hash-table)))
|
||||
|
||||
(compat-defmacro thread-first (&rest forms) ;; <compat-tests:thread-first>
|
||||
"Thread FORMS elements as the first argument of their successor.
|
||||
Example:
|
||||
(thread-first
|
||||
@@ -183,7 +186,6 @@ Is equivalent to:
|
||||
(+ (- (/ (+ 5 20) 25)) 40)
|
||||
Note how the single `-' got converted into a list before
|
||||
threading."
|
||||
:feature 'subr-x
|
||||
(declare (indent 1)
|
||||
(debug (form &rest [&or symbolp (sexp &rest form)])))
|
||||
(let ((body (car forms)))
|
||||
@@ -195,7 +197,7 @@ threading."
|
||||
(cdr form))))
|
||||
body))
|
||||
|
||||
(compat-defmacro thread-last (&rest forms)
|
||||
(compat-defmacro thread-last (&rest forms) ;; <compat-tests:thread-last>
|
||||
"Thread FORMS elements as the last argument of their successor.
|
||||
Example:
|
||||
(thread-last
|
||||
@@ -208,7 +210,6 @@ Is equivalent to:
|
||||
(+ 40 (- (/ 25 (+ 20 5))))
|
||||
Note how the single `-' got converted into a list before
|
||||
threading."
|
||||
:feature 'subr-x
|
||||
(declare (indent 1) (debug thread-first))
|
||||
(let ((body (car forms)))
|
||||
(dolist (form (cdr forms))
|
||||
@@ -219,10 +220,31 @@ threading."
|
||||
|
||||
;;;; Defined in macroexp.el
|
||||
|
||||
(declare-function macrop nil (object))
|
||||
(compat-defun macroexpand-1 (form &optional environment)
|
||||
(compat-defun macroexp-parse-body (body) ;; <compat-tests:macroexp-parse-body>
|
||||
"Parse a function BODY into (DECLARATIONS . EXPS)."
|
||||
(let ((decls ()))
|
||||
(while (and (cdr body)
|
||||
(let ((e (car body)))
|
||||
(or (stringp e)
|
||||
(memq (car-safe e)
|
||||
'(:documentation declare interactive cl-declare)))))
|
||||
(push (pop body) decls))
|
||||
(cons (nreverse decls) body)))
|
||||
|
||||
(compat-defun macroexp-quote (v) ;; <compat-tests:macroexp-quote>
|
||||
"Return an expression E such that `(eval E)' is V.
|
||||
|
||||
E is either V or (quote V) depending on whether V evaluates to
|
||||
itself or not."
|
||||
(if (and (not (consp v))
|
||||
(or (keywordp v)
|
||||
(not (symbolp v))
|
||||
(memq v '(nil t))))
|
||||
v
|
||||
(list 'quote v)))
|
||||
|
||||
(compat-defun macroexpand-1 (form &optional environment) ;; <compat-tests:macroexpand-1>
|
||||
"Perform (at most) one step of macro expansion."
|
||||
:feature 'macroexp
|
||||
(cond
|
||||
((consp form)
|
||||
(let* ((head (car form))
|
||||
@@ -245,78 +267,5 @@ threading."
|
||||
form))))))))
|
||||
(t form)))
|
||||
|
||||
;;;; Defined in byte-run.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun function-put (func prop value)
|
||||
"Set FUNCTION's property PROP to VALUE.
|
||||
The namespace for PROP is shared with symbols.
|
||||
So far, FUNCTION can only be a symbol, not a lambda expression."
|
||||
:version "24.4"
|
||||
(put func prop value))
|
||||
|
||||
;;;; Defined in files.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun directory-files-recursively
|
||||
(dir regexp &optional include-directories predicate follow-symlinks)
|
||||
"Return list of all files under directory DIR whose names match REGEXP.
|
||||
This function works recursively. Files are returned in \"depth
|
||||
first\" order, and files from each directory are sorted in
|
||||
alphabetical order. Each file name appears in the returned list
|
||||
in its absolute form.
|
||||
|
||||
By default, the returned list excludes directories, but if
|
||||
optional argument INCLUDE-DIRECTORIES is non-nil, they are
|
||||
included.
|
||||
|
||||
PREDICATE can be either nil (which means that all subdirectories
|
||||
of DIR are descended into), t (which means that subdirectories that
|
||||
can't be read are ignored), or a function (which is called with
|
||||
the name of each subdirectory, and should return non-nil if the
|
||||
subdirectory is to be descended into).
|
||||
|
||||
If FOLLOW-SYMLINKS is non-nil, symbolic links that point to
|
||||
directories are followed. Note that this can lead to infinite
|
||||
recursion."
|
||||
:realname compat--directory-files-recursively
|
||||
(let* ((result nil)
|
||||
(files nil)
|
||||
(dir (directory-file-name dir))
|
||||
;; When DIR is "/", remote file names like "/method:" could
|
||||
;; also be offered. We shall suppress them.
|
||||
(tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir)))))
|
||||
(dolist (file (sort (file-name-all-completions "" dir)
|
||||
'string<))
|
||||
(unless (member file '("./" "../"))
|
||||
(if (directory-name-p file)
|
||||
(let* ((leaf (substring file 0 (1- (length file))))
|
||||
(full-file (concat dir "/" leaf)))
|
||||
;; Don't follow symlinks to other directories.
|
||||
(when (and (or (not (file-symlink-p full-file))
|
||||
(and (file-symlink-p full-file)
|
||||
follow-symlinks))
|
||||
;; Allow filtering subdirectories.
|
||||
(or (eq predicate nil)
|
||||
(eq predicate t)
|
||||
(funcall predicate full-file)))
|
||||
(let ((sub-files
|
||||
(if (eq predicate t)
|
||||
(condition-case nil
|
||||
(compat--directory-files-recursively
|
||||
full-file regexp include-directories
|
||||
predicate follow-symlinks)
|
||||
(file-error nil))
|
||||
(compat--directory-files-recursively
|
||||
full-file regexp include-directories
|
||||
predicate follow-symlinks))))
|
||||
(setq result (nconc result sub-files))))
|
||||
(when (and include-directories
|
||||
(string-match regexp leaf))
|
||||
(setq result (nconc result (list full-file)))))
|
||||
(when (string-match regexp file)
|
||||
(push (concat dir "/" file) files)))))
|
||||
(nconc result (nreverse files))))
|
||||
|
||||
(compat--inhibit-prefixed (provide 'compat-25))
|
||||
(provide 'compat-25)
|
||||
;;; compat-25.el ends here
|
||||
|
||||
@@ -1,11 +1,6 @@
|
||||
;;; compat-26.el --- Compatibility Layer for Emacs 26.1 -*- lexical-binding: t; -*-
|
||||
;;; compat-26.el --- Functionality added in Emacs 26.1 -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
|
||||
;; URL: https://git.sr.ht/~pkal/compat/
|
||||
;; Keywords: lisp
|
||||
;; 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
|
||||
@@ -22,337 +17,284 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Find here the functionality added in Emacs 26.1, needed by older
|
||||
;; versions.
|
||||
;;
|
||||
;; Only load this library if you need to use one of the following
|
||||
;; functions:
|
||||
;;
|
||||
;; - `compat-sort'
|
||||
;; - `line-number-at-pos'
|
||||
;; - `compat-alist-get'
|
||||
;; - `string-trim-left'
|
||||
;; - `string-trim-right'
|
||||
;; - `string-trim'
|
||||
;; Functionality added in Emacs 26.1, needed by older Emacs versions.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'compat-macs "compat-macs.el")
|
||||
(eval-when-compile (load "compat-macs.el" nil t t))
|
||||
(compat-require compat-25 "25.1")
|
||||
|
||||
(compat-declare-version "26.1")
|
||||
|
||||
;;;; Defined in eval.c
|
||||
|
||||
(compat-defun func-arity (func)
|
||||
"Return minimum and maximum number of args allowed for FUNC.
|
||||
FUNC must be a function of some kind.
|
||||
The returned value is a cons cell (MIN . MAX). MIN is the minimum number
|
||||
of args. MAX is the maximum number, or the symbol `many', for a
|
||||
function with `&rest' args, or `unevalled' for a special form."
|
||||
:realname compat--func-arity
|
||||
(cond
|
||||
((or (null func) (and (symbolp func) (not (fboundp func))))
|
||||
(signal 'void-function func))
|
||||
((and (symbolp func) (not (null func)))
|
||||
(compat--func-arity (symbol-function func)))
|
||||
((eq (car-safe func) 'macro)
|
||||
(compat--func-arity (cdr func)))
|
||||
((subrp func)
|
||||
(subr-arity func))
|
||||
((memq (car-safe func) '(closure lambda))
|
||||
;; See lambda_arity from eval.c
|
||||
(when (eq (car func) 'closure)
|
||||
(setq func (cdr func)))
|
||||
(let ((syms-left (if (consp func)
|
||||
(car func)
|
||||
(signal 'invalid-function func)))
|
||||
(min-args 0) (max-args 0) optional)
|
||||
(catch 'many
|
||||
(dolist (next syms-left)
|
||||
(cond
|
||||
((not (symbolp next))
|
||||
(signal 'invalid-function func))
|
||||
((eq next '&rest)
|
||||
(throw 'many (cons min-args 'many)))
|
||||
((eq next '&optional)
|
||||
(setq optional t))
|
||||
(t (unless optional
|
||||
(setq min-args (1+ min-args)))
|
||||
(setq max-args (1+ max-args)))))
|
||||
(cons min-args max-args))))
|
||||
((and (byte-code-function-p func) (numberp (aref func 0)))
|
||||
;; See get_byte_code_arity from bytecode.c
|
||||
(let ((at (aref func 0)))
|
||||
(cons (logand at 127)
|
||||
(if (= (logand at 128) 0)
|
||||
(ash at -8)
|
||||
'many))))
|
||||
((and (byte-code-function-p func) (numberp (aref func 0)))
|
||||
;; See get_byte_code_arity from bytecode.c
|
||||
(let ((at (aref func 0)))
|
||||
(cons (logand at 127)
|
||||
(if (= (logand at 128) 0)
|
||||
(ash at -8)
|
||||
'many))))
|
||||
((and (byte-code-function-p func) (listp (aref func 0)))
|
||||
;; Based on `byte-compile-make-args-desc', this is required for
|
||||
;; old versions of Emacs that don't use a integer for the argument
|
||||
;; list description, per e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6.
|
||||
(let ((arglist (aref func 0)) (mandatory 0) nonrest)
|
||||
(while (and arglist (not (memq (car arglist) '(&optional &rest))))
|
||||
(setq mandatory (1+ mandatory))
|
||||
(setq arglist (cdr arglist)))
|
||||
(setq nonrest mandatory)
|
||||
(when (eq (car arglist) '&optional)
|
||||
(setq arglist (cdr arglist))
|
||||
(while (and arglist (not (eq (car arglist) '&rest)))
|
||||
(setq nonrest (1+ nonrest))
|
||||
(setq arglist (cdr arglist))))
|
||||
(cons mandatory (if arglist 'many nonrest))))
|
||||
((autoloadp func)
|
||||
(autoload-do-load func)
|
||||
(compat--func-arity func))
|
||||
((signal 'invalid-function func))))
|
||||
(compat-version "26.1")
|
||||
|
||||
;;;; Defined in fns.c
|
||||
|
||||
(compat-defun assoc (key alist &optional testfn)
|
||||
"Handle the optional argument TESTFN.
|
||||
Equality is defined by the function TESTFN, defaulting to
|
||||
`equal'. TESTFN is called with 2 arguments: a car of an alist
|
||||
element and KEY. With no optional argument, the function behaves
|
||||
just like `assoc'."
|
||||
:prefix t
|
||||
(if testfn
|
||||
(catch 'found
|
||||
(dolist (ent alist)
|
||||
(when (funcall testfn (car ent) key)
|
||||
(throw 'found ent))))
|
||||
(assoc key alist)))
|
||||
(compat-defun buffer-hash (&optional buffer-or-name) ;; <compat-tests:buffer-hash>
|
||||
"Return a hash of the contents of BUFFER-OR-NAME.
|
||||
This hash is performed on the raw internal format of the buffer,
|
||||
disregarding any coding systems. If nil, use the current buffer.
|
||||
|
||||
(compat-defun mapcan (func sequence)
|
||||
This function is useful for comparing two buffers running in the same
|
||||
Emacs, but is not guaranteed to return the same hash between different
|
||||
Emacs versions. It should be somewhat more efficient on larger
|
||||
buffers than `secure-hash' is, and should not allocate more memory.
|
||||
|
||||
It should not be used for anything security-related. See
|
||||
`secure-hash' for these applications."
|
||||
(with-current-buffer (or buffer-or-name (current-buffer))
|
||||
(save-restriction
|
||||
(widen)
|
||||
(sha1 (current-buffer) (point-min) (point-max)))))
|
||||
|
||||
(compat-defun mapcan (func sequence) ;; <compat-tests:mapcan>
|
||||
"Apply FUNC to each element of SEQUENCE.
|
||||
Concatenate the results by altering them (using `nconc').
|
||||
SEQUENCE may be a list, a vector, a boolean vector, or a string."
|
||||
(apply #'nconc (mapcar func sequence)))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun line-number-at-pos (&optional position absolute)
|
||||
"Handle optional argument ABSOLUTE:
|
||||
|
||||
If the buffer is narrowed, the return value by default counts the lines
|
||||
from the beginning of the accessible portion of the buffer. But if the
|
||||
second optional argument ABSOLUTE is non-nil, the value counts the lines
|
||||
from the absolute start of the buffer, disregarding the narrowing."
|
||||
:prefix t
|
||||
(compat-defun line-number-at-pos (&optional position absolute) ;; <compat-tests:line-number-at-pos>
|
||||
"Handle optional argument ABSOLUTE."
|
||||
:extended t
|
||||
(if absolute
|
||||
(save-restriction
|
||||
(widen)
|
||||
(line-number-at-pos position))
|
||||
(line-number-at-pos position)))
|
||||
|
||||
;;;; Defined in simple.el
|
||||
|
||||
(compat-defun region-bounds () ;; <compat-tests:region-bounds>
|
||||
"Return the boundaries of the region.
|
||||
Value is a list of one or more cons cells of the form (START . END).
|
||||
It will have more than one cons cell when the region is non-contiguous,
|
||||
see `region-noncontiguous-p' and `extract-rectangle-bounds'."
|
||||
(if (eval-when-compile (< emacs-major-version 25))
|
||||
;; FIXME: The `region-extract-function' of Emacs 24 has no support for the
|
||||
;; bounds argument.
|
||||
(list (cons (region-beginning) (region-end)))
|
||||
(funcall region-extract-function 'bounds)))
|
||||
|
||||
;;;; Defined in subr.el
|
||||
|
||||
(declare-function compat--alist-get-full-elisp "compat-25"
|
||||
(key alist &optional default remove testfn))
|
||||
(compat-defun alist-get (key alist &optional default remove testfn)
|
||||
"Handle TESTFN manually."
|
||||
:realname compat--alist-get-handle-testfn
|
||||
:prefix t
|
||||
(if testfn
|
||||
(compat--alist-get-full-elisp key alist default remove testfn)
|
||||
(alist-get key alist default remove)))
|
||||
(compat-defun provided-mode-derived-p (mode &rest modes) ;; <compat-tests:provided-derived-mode-p>
|
||||
"Non-nil if MODE is derived from one of MODES.
|
||||
Uses the `derived-mode-parent' property of the symbol to trace backwards.
|
||||
If you just want to check `major-mode', use `derived-mode-p'."
|
||||
;; If MODE is an alias, then look up the real mode function first.
|
||||
(let ((alias (symbol-function mode)))
|
||||
(when (and alias (symbolp alias))
|
||||
(setq mode alias)))
|
||||
(while
|
||||
(and
|
||||
(not (memq mode modes))
|
||||
(let* ((parent (get mode 'derived-mode-parent))
|
||||
(parentfn (symbol-function parent)))
|
||||
(setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
|
||||
mode)
|
||||
|
||||
(gv-define-expander compat-alist-get
|
||||
(lambda (do key alist &optional default remove testfn)
|
||||
(macroexp-let2 macroexp-copyable-p k key
|
||||
(gv-letplace (getter setter) alist
|
||||
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
|
||||
(compat-assoc ,k ,getter ,testfn)
|
||||
(assq ,k ,getter))
|
||||
(funcall do (if (null default) `(cdr ,p)
|
||||
`(if ,p (cdr ,p) ,default))
|
||||
(lambda (v)
|
||||
(macroexp-let2 nil v v
|
||||
(let ((set-exp
|
||||
`(if ,p (setcdr ,p ,v)
|
||||
,(funcall setter
|
||||
`(cons (setq ,p (cons ,k ,v))
|
||||
,getter)))))
|
||||
`(progn
|
||||
,(cond
|
||||
((null remove) set-exp)
|
||||
((or (eql v default)
|
||||
(and (eq (car-safe v) 'quote)
|
||||
(eq (car-safe default) 'quote)
|
||||
(eql (cadr v) (cadr default))))
|
||||
`(if ,p ,(funcall setter `(delq ,p ,getter))))
|
||||
(t
|
||||
`(cond
|
||||
((not (eql ,default ,v)) ,set-exp)
|
||||
(,p ,(funcall setter
|
||||
`(delq ,p ,getter))))))
|
||||
,v))))))))))
|
||||
(compat-defun assoc (key alist &optional testfn) ;; <compat-tests:assoc>
|
||||
"Handle the optional TESTFN."
|
||||
:extended t
|
||||
(cond
|
||||
((or (eq testfn #'eq)
|
||||
(and (not testfn) (or (symbolp key) (integerp key)))) ;; eq_comparable_value
|
||||
(assq key alist))
|
||||
((or (eq testfn #'equal) (not testfn))
|
||||
(assoc key alist))
|
||||
(t
|
||||
(catch 'found
|
||||
(dolist (ent alist)
|
||||
(when (funcall testfn (car ent) key)
|
||||
(throw 'found ent)))))))
|
||||
|
||||
(compat-defun string-trim-left (string &optional regexp)
|
||||
"Trim STRING of leading string matching REGEXP.
|
||||
(compat-defun alist-get (key alist &optional default remove testfn) ;; <compat-tests:alist-get>
|
||||
"Handle optional argument TESTFN."
|
||||
:extended "25.1"
|
||||
(ignore remove)
|
||||
(let ((x (if (not testfn)
|
||||
(assq key alist)
|
||||
(compat--assoc key alist testfn))))
|
||||
(if x (cdr x) default)))
|
||||
|
||||
REGEXP defaults to \"[ \\t\\n\\r]+\"."
|
||||
:realname compat--string-trim-left
|
||||
:prefix t
|
||||
(compat-guard t ;; <compat-tests:alist-get-gv>
|
||||
(gv-define-expander compat--alist-get
|
||||
(lambda (do key alist &optional default remove testfn)
|
||||
(macroexp-let2 macroexp-copyable-p k key
|
||||
(gv-letplace (getter setter) alist
|
||||
(macroexp-let2 nil p `(compat--assoc ,k ,getter ,testfn)
|
||||
(funcall do (if (null default) `(cdr ,p)
|
||||
`(if ,p (cdr ,p) ,default))
|
||||
(lambda (v)
|
||||
(macroexp-let2 nil v v
|
||||
(let ((set-exp
|
||||
`(if ,p (setcdr ,p ,v)
|
||||
,(funcall setter
|
||||
`(cons (setq ,p (cons ,k ,v))
|
||||
,getter)))))
|
||||
`(progn
|
||||
,(cond
|
||||
((null remove) set-exp)
|
||||
((or (eql v default)
|
||||
(and (eq (car-safe v) 'quote)
|
||||
(eq (car-safe default) 'quote)
|
||||
(eql (cadr v) (cadr default))))
|
||||
`(if ,p ,(funcall setter `(delq ,p ,getter))))
|
||||
(t
|
||||
`(cond
|
||||
((not (eql ,default ,v)) ,set-exp)
|
||||
(,p ,(funcall setter
|
||||
`(delq ,p ,getter))))))
|
||||
,v))))))))))
|
||||
(unless (get 'alist-get 'gv-expander)
|
||||
(put 'alist-get 'gv-expander (get 'compat--alist-get 'gv-expander))))
|
||||
|
||||
(compat-defun string-trim-left (string &optional regexp) ;; <compat-tests:string-trim-left>
|
||||
"Handle optional argument REGEXP."
|
||||
:extended t
|
||||
(if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
|
||||
(substring string (match-end 0))
|
||||
string))
|
||||
|
||||
(compat-defun string-trim-right (string &optional regexp)
|
||||
"Trim STRING of trailing string matching REGEXP.
|
||||
|
||||
REGEXP defaults to \"[ \\t\\n\\r]+\"."
|
||||
:realname compat--string-trim-right
|
||||
:prefix t
|
||||
(compat-defun string-trim-right (string &optional regexp) ;; <compat-tests:string-trim-right>
|
||||
"Handle optional argument REGEXP."
|
||||
:extended t
|
||||
(let ((i (string-match-p
|
||||
(concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
|
||||
string)))
|
||||
(if i (substring string 0 i) string)))
|
||||
|
||||
(compat-defun string-trim (string &optional trim-left trim-right)
|
||||
"Trim STRING of leading with and trailing matching TRIM-LEFT and TRIM-RIGHT.
|
||||
|
||||
TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
|
||||
:prefix t
|
||||
;; `string-trim-left' and `string-trim-right' were moved from subr-x
|
||||
;; to subr in Emacs 27, so to avoid loading subr-x we use the
|
||||
;; compatibility function here:
|
||||
(compat-defun string-trim (string &optional trim-left trim-right) ;; <compat-tests:string-trim>
|
||||
"Handle optional arguments TRIM-LEFT and TRIM-RIGHT."
|
||||
:extended t
|
||||
(compat--string-trim-left
|
||||
(compat--string-trim-right
|
||||
string
|
||||
trim-right)
|
||||
trim-left))
|
||||
|
||||
(compat-defun caaar (x)
|
||||
(compat-defun caaar (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `car' of the `car' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(car (car (car x))))
|
||||
|
||||
(compat-defun caadr (x)
|
||||
(compat-defun caadr (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `car' of the `car' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(car (car (cdr x))))
|
||||
|
||||
(compat-defun cadar (x)
|
||||
(compat-defun cadar (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `car' of the `cdr' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(car (cdr (car x))))
|
||||
|
||||
(compat-defun caddr (x)
|
||||
(compat-defun caddr (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `car' of the `cdr' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(car (cdr (cdr x))))
|
||||
|
||||
(compat-defun cdaar (x)
|
||||
(compat-defun cdaar (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `cdr' of the `car' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(cdr (car (car x))))
|
||||
|
||||
(compat-defun cdadr (x)
|
||||
(compat-defun cdadr (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `cdr' of the `car' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(cdr (car (cdr x))))
|
||||
|
||||
(compat-defun cddar (x)
|
||||
(compat-defun cddar (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `cdr' of the `cdr' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(cdr (cdr (car x))))
|
||||
|
||||
(compat-defun cdddr (x)
|
||||
(compat-defun cdddr (x) ;; <compat-tests:cXXXr>
|
||||
"Return the `cdr' of the `cdr' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(cdr (cdr (cdr x))))
|
||||
|
||||
(compat-defun caaaar (x)
|
||||
(compat-defun caaaar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `car' of the `car' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(car (car (car (car x)))))
|
||||
|
||||
(compat-defun caaadr (x)
|
||||
(compat-defun caaadr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `car' of the `car' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(car (car (car (cdr x)))))
|
||||
|
||||
(compat-defun caadar (x)
|
||||
(compat-defun caadar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `car' of the `cdr' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(car (car (cdr (car x)))))
|
||||
|
||||
(compat-defun caaddr (x)
|
||||
(compat-defun caaddr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(car (car (cdr (cdr x)))))
|
||||
|
||||
(compat-defun cadaar (x)
|
||||
(compat-defun cadaar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `cdr' of the `car' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(car (cdr (car (car x)))))
|
||||
|
||||
(compat-defun cadadr (x)
|
||||
(compat-defun cadadr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(car (cdr (car (cdr x)))))
|
||||
|
||||
(compat-defun caddar (x)
|
||||
(compat-defun caddar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(car (cdr (cdr (car x)))))
|
||||
|
||||
(compat-defun cadddr (x)
|
||||
(compat-defun cadddr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(car (cdr (cdr (cdr x)))))
|
||||
|
||||
(compat-defun cdaaar (x)
|
||||
(compat-defun cdaaar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `car' of the `car' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(cdr (car (car (car x)))))
|
||||
|
||||
(compat-defun cdaadr (x)
|
||||
(compat-defun cdaadr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(cdr (car (car (cdr x)))))
|
||||
|
||||
(compat-defun cdadar (x)
|
||||
(compat-defun cdadar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(cdr (car (cdr (car x)))))
|
||||
|
||||
(compat-defun cdaddr (x)
|
||||
(compat-defun cdaddr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(cdr (car (cdr (cdr x)))))
|
||||
|
||||
(compat-defun cddaar (x)
|
||||
(compat-defun cddaar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(cdr (cdr (car (car x)))))
|
||||
|
||||
(compat-defun cddadr (x)
|
||||
(compat-defun cddadr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(cdr (cdr (car (cdr x)))))
|
||||
|
||||
(compat-defun cdddar (x)
|
||||
(compat-defun cdddar (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
|
||||
(declare (pure t))
|
||||
(cdr (cdr (cdr (car x)))))
|
||||
|
||||
(compat-defun cddddr (x)
|
||||
(compat-defun cddddr (x) ;; <compat-tests:cXXXXr>
|
||||
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
|
||||
(declare (pure t))
|
||||
(cdr (cdr (cdr (cdr x)))))
|
||||
|
||||
(compat-defvar gensym-counter 0
|
||||
(compat-defvar gensym-counter 0 ;; <compat-tests:gensym>
|
||||
"Number used to construct the name of the next symbol created by `gensym'.")
|
||||
|
||||
(compat-defun gensym (&optional prefix)
|
||||
(compat-defun gensym (&optional prefix) ;; <compat-tests:gensym>
|
||||
"Return a new uninterned symbol.
|
||||
The name is made by appending `gensym-counter' to PREFIX.
|
||||
PREFIX is a string, and defaults to \"g\"."
|
||||
@@ -361,27 +303,52 @@ PREFIX is a string, and defaults to \"g\"."
|
||||
(1+ gensym-counter)))))
|
||||
(make-symbol (format "%s%d" (or prefix "g") num))))
|
||||
|
||||
(compat-defmacro if-let* (varlist then &rest else) ;; <compat-tests:if-let*>
|
||||
"Bind variables according to VARLIST and evaluate THEN or ELSE.
|
||||
This is like `if-let' but doesn't handle a VARLIST of the form
|
||||
\(SYMBOL SOMETHING) specially."
|
||||
(declare (indent 2)
|
||||
(debug ((&rest [&or symbolp (symbolp form) (form)])
|
||||
body)))
|
||||
(let ((empty (make-symbol "s"))
|
||||
(last t) list)
|
||||
(dolist (var varlist)
|
||||
(push `(,(if (cdr var) (car var) empty)
|
||||
(and ,last ,(if (cdr var) (cadr var) (car var))))
|
||||
list)
|
||||
(when (or (cdr var) (consp (car var)))
|
||||
(setq last (caar list))))
|
||||
`(let* ,(nreverse list)
|
||||
(if ,(caar list) ,then ,@else))))
|
||||
|
||||
(compat-defmacro when-let* (varlist &rest body) ;; <compat-tests:when-let*>
|
||||
"Bind variables according to VARLIST and conditionally evaluate BODY.
|
||||
This is like `when-let' but doesn't handle a VARLIST of the form
|
||||
\(SYMBOL SOMETHING) specially."
|
||||
(declare (indent 1) (debug if-let*))
|
||||
(list 'if-let* varlist (macroexp-progn body)))
|
||||
|
||||
(compat-defmacro and-let* (varlist &rest body) ;; <compat-tests:and-let*>
|
||||
"Bind variables according to VARLIST and conditionally evaluate BODY.
|
||||
Like `when-let*', except if BODY is empty and all the bindings
|
||||
are non-nil, then the result is non-nil."
|
||||
(declare (indent 1)
|
||||
(debug ((&rest [&or symbolp (symbolp form) (form)])
|
||||
body)))
|
||||
(let ((empty (make-symbol "s"))
|
||||
(last t) list)
|
||||
(dolist (var varlist)
|
||||
(push `(,(if (cdr var) (car var) empty)
|
||||
(and ,last ,(if (cdr var) (cadr var) (car var))))
|
||||
list)
|
||||
(when (or (cdr var) (consp (car var)))
|
||||
(setq last (caar list))))
|
||||
`(let* ,(nreverse list)
|
||||
(if ,(caar list) ,(macroexp-progn (or body '(t)))))))
|
||||
|
||||
;;;; Defined in files.el
|
||||
|
||||
(declare-function temporary-file-directory nil)
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix)
|
||||
"Create a temporary file as close as possible to `default-directory'.
|
||||
If PREFIX is a relative file name, and `default-directory' is a
|
||||
remote file name or located on a mounted file systems, the
|
||||
temporary file is created in the directory returned by the
|
||||
function `temporary-file-directory'. Otherwise, the function
|
||||
`make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the
|
||||
same meaning as in `make-temp-file'."
|
||||
(let ((handler (find-file-name-handler
|
||||
default-directory 'make-nearby-temp-file)))
|
||||
(if (and handler (not (file-name-absolute-p default-directory)))
|
||||
(funcall handler 'make-nearby-temp-file prefix dir-flag suffix)
|
||||
(let ((temporary-file-directory (temporary-file-directory)))
|
||||
(make-temp-file prefix dir-flag suffix)))))
|
||||
|
||||
(compat-defvar mounted-file-systems
|
||||
(compat-defvar mounted-file-systems ;; <compat-tests:mounted-file-systems>
|
||||
(eval-when-compile
|
||||
(if (memq system-type '(windows-nt cygwin))
|
||||
"^//[^/]+/"
|
||||
@@ -389,35 +356,16 @@ same meaning as in `make-temp-file'."
|
||||
"^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))))
|
||||
"File systems that ought to be mounted.")
|
||||
|
||||
(compat-defun file-local-name (file)
|
||||
(compat-defun file-local-name (file) ;; <compat-tests:file-local-name>
|
||||
"Return the local name component of FILE.
|
||||
This function removes from FILE the specification of the remote host
|
||||
and the method of accessing the host, leaving only the part that
|
||||
identifies FILE locally on the remote system.
|
||||
The returned file name can be used directly as argument of
|
||||
`process-file', `start-file-process', or `shell-command'."
|
||||
:realname compat--file-local-name
|
||||
(or (file-remote-p file 'localname) file))
|
||||
|
||||
(compat-defun file-name-quoted-p (name &optional top)
|
||||
"Whether NAME is quoted with prefix \"/:\".
|
||||
If NAME is a remote file name and TOP is nil, check the local part of NAME."
|
||||
:realname compat--file-name-quoted-p
|
||||
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
|
||||
(string-prefix-p "/:" (compat--file-local-name name))))
|
||||
|
||||
(compat-defun file-name-quote (name &optional top)
|
||||
"Add the quotation prefix \"/:\" to file NAME.
|
||||
If NAME is a remote file name and TOP is nil, the local part of
|
||||
NAME is quoted. If NAME is already a quoted file name, NAME is
|
||||
returned unchanged."
|
||||
(let ((file-name-handler-alist (unless top file-name-handler-alist)))
|
||||
(if (compat--file-name-quoted-p name top)
|
||||
name
|
||||
(concat (file-remote-p name) "/:" (compat--file-local-name name)))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun temporary-file-directory ()
|
||||
(compat-defun temporary-file-directory () ;; <compat-tests:temporary-file-directory>
|
||||
"The directory for writing temporary files.
|
||||
In case of a remote `default-directory', this is a directory for
|
||||
temporary files on that remote host. If such a directory does
|
||||
@@ -426,87 +374,107 @@ mounted file system (see `mounted-file-systems'), the function
|
||||
returns `default-directory'.
|
||||
For a non-remote and non-mounted `default-directory', the value of
|
||||
the variable `temporary-file-directory' is returned."
|
||||
;; NOTE: The handler may fail with an error, since the
|
||||
;; `temporary-file-directory' handler was introduced in Emacs 26.
|
||||
(let ((handler (find-file-name-handler
|
||||
default-directory 'temporary-file-directory)))
|
||||
(if handler
|
||||
(funcall handler 'temporary-file-directory)
|
||||
(if (string-match mounted-file-systems default-directory)
|
||||
default-directory
|
||||
temporary-file-directory))))
|
||||
(or (and handler (ignore-errors (funcall handler 'temporary-file-directory)))
|
||||
(if-let ((remote (file-remote-p default-directory)))
|
||||
(concat remote "/tmp/") ;; FIXME: Guess /tmp on remote host
|
||||
(if (string-match mounted-file-systems default-directory)
|
||||
default-directory
|
||||
temporary-file-directory)))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-type (attributes)
|
||||
(compat-defun make-temp-file (prefix &optional dir-flag suffix text) ;; <compat-tests:make-temp-file>
|
||||
"Handle optional argument TEXT."
|
||||
:extended t
|
||||
(let ((file (make-temp-file prefix dir-flag suffix)))
|
||||
(when text
|
||||
(with-temp-buffer
|
||||
(insert text)
|
||||
(write-region (point-min) (point-max) file)))
|
||||
file))
|
||||
|
||||
(compat-defun make-nearby-temp-file (prefix &optional dir-flag suffix) ;; <compat-tests:make-nearby-temp-file>
|
||||
"Create a temporary file as close as possible to `default-directory'.
|
||||
If PREFIX is a relative file name, and `default-directory' is a
|
||||
remote file name or located on a mounted file systems, the
|
||||
temporary file is created in the directory returned by the
|
||||
function `temporary-file-directory'. Otherwise, the function
|
||||
`make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the
|
||||
same meaning as in `make-temp-file'."
|
||||
;; NOTE: The handler may fail with an error, since the
|
||||
;; `make-nearby-temp-file' handler was introduced in Emacs 26.
|
||||
(let ((handler (and (not (file-name-absolute-p default-directory))
|
||||
(find-file-name-handler
|
||||
default-directory 'make-nearby-temp-file))))
|
||||
(or (and handler (ignore-errors (funcall handler 'make-nearby-temp-file
|
||||
prefix dir-flag suffix)))
|
||||
(let ((temporary-file-directory (temporary-file-directory)))
|
||||
(make-temp-file prefix dir-flag suffix)))))
|
||||
|
||||
(compat-defun file-attribute-type (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The type field in ATTRIBUTES returned by `file-attributes'.
|
||||
The value is either t for directory, string (name linked to) for
|
||||
symbolic link, or nil."
|
||||
(nth 0 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-link-number (attributes)
|
||||
(compat-defun file-attribute-link-number (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"Return the number of links in ATTRIBUTES returned by `file-attributes'."
|
||||
(nth 1 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-user-id (attributes)
|
||||
(compat-defun file-attribute-user-id (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The UID field in ATTRIBUTES returned by `file-attributes'.
|
||||
This is either a string or a number. If a string value cannot be
|
||||
looked up, a numeric value, either an integer or a float, is
|
||||
returned."
|
||||
(nth 2 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-group-id (attributes)
|
||||
(compat-defun file-attribute-group-id (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The GID field in ATTRIBUTES returned by `file-attributes'.
|
||||
This is either a string or a number. If a string value cannot be
|
||||
looked up, a numeric value, either an integer or a float, is
|
||||
returned."
|
||||
(nth 3 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-access-time (attributes)
|
||||
(compat-defun file-attribute-access-time (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The last access time in ATTRIBUTES returned by `file-attributes'.
|
||||
This a Lisp timestamp in the style of `current-time'."
|
||||
(nth 4 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-modification-time (attributes)
|
||||
(compat-defun file-attribute-modification-time (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The modification time in ATTRIBUTES returned by `file-attributes'.
|
||||
This is the time of the last change to the file's contents, and
|
||||
is a Lisp timestamp in the style of `current-time'."
|
||||
(nth 5 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-status-change-time (attributes)
|
||||
(compat-defun file-attribute-status-change-time (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The status modification time in ATTRIBUTES returned by `file-attributes'.
|
||||
This is the time of last change to the file's attributes: owner
|
||||
and group, access mode bits, etc., and is a Lisp timestamp in the
|
||||
style of `current-time'."
|
||||
(nth 6 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-size (attributes)
|
||||
(compat-defun file-attribute-size (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
|
||||
(nth 7 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-modes (attributes)
|
||||
(compat-defun file-attribute-modes (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The file modes in ATTRIBUTES returned by `file-attributes'.
|
||||
This is a string of ten letters or dashes as in ls -l."
|
||||
(nth 8 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-inode-number (attributes)
|
||||
(compat-defun file-attribute-inode-number (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The inode number in ATTRIBUTES returned by `file-attributes'.
|
||||
It is a nonnegative integer."
|
||||
(nth 10 attributes))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-attribute-device-number (attributes)
|
||||
(compat-defun file-attribute-device-number (attributes) ;; <compat-tests:file-attribute-getters>
|
||||
"The file system device number in ATTRIBUTES returned by `file-attributes'.
|
||||
It is an integer."
|
||||
(nth 11 attributes))
|
||||
|
||||
(compat-defun file-attribute-collect (attributes &rest attr-names)
|
||||
(compat-defun file-attribute-collect (attributes &rest attr-names) ;; <compat-tests:file-attribute-collect>
|
||||
"Return a sublist of ATTRIBUTES returned by `file-attributes'.
|
||||
ATTR-NAMES are symbols with the selected attribute names.
|
||||
|
||||
@@ -534,105 +502,28 @@ inode-number and device-number."
|
||||
(error "Wrong attribute name '%S'" attr))))
|
||||
(nreverse result)))
|
||||
|
||||
;;;; Defined in subr-x.el
|
||||
;;;; Defined in mouse.el
|
||||
|
||||
(compat-defmacro if-let* (varlist then &rest else)
|
||||
"Bind variables according to VARLIST and evaluate THEN or ELSE.
|
||||
This is like `if-let' but doesn't handle a VARLIST of the form
|
||||
\(SYMBOL SOMETHING) specially."
|
||||
:realname compat--if-let*
|
||||
:feature 'subr-x
|
||||
(declare (indent 2)
|
||||
(debug ((&rest [&or symbolp (symbolp form) (form)])
|
||||
body)))
|
||||
(let ((empty (make-symbol "s"))
|
||||
(last t) list)
|
||||
(dolist (var varlist)
|
||||
(push `(,(if (cdr var) (car var) empty)
|
||||
(and ,last ,(or (cadr var) (car var))))
|
||||
list)
|
||||
(when (or (cdr var) (consp (car var)))
|
||||
(setq last (caar list))))
|
||||
`(let* ,(nreverse list)
|
||||
(if ,(caar list) ,then ,@else))))
|
||||
|
||||
(compat-defmacro when-let* (varlist &rest body)
|
||||
"Bind variables according to VARLIST and conditionally evaluate BODY.
|
||||
This is like `when-let' but doesn't handle a VARLIST of the form
|
||||
\(SYMBOL SOMETHING) specially."
|
||||
;; :feature 'subr-x
|
||||
(declare (indent 1) (debug if-let*))
|
||||
(let ((empty (make-symbol "s"))
|
||||
(last t) list)
|
||||
(dolist (var varlist)
|
||||
(push `(,(if (cdr var) (car var) empty)
|
||||
(and ,last ,(or (cadr var) (car var))))
|
||||
list)
|
||||
(when (or (cdr var) (consp (car var)))
|
||||
(setq last (caar list))))
|
||||
`(let* ,(nreverse list)
|
||||
(when ,(caar list) ,@body))))
|
||||
|
||||
(compat-defmacro and-let* (varlist &rest body)
|
||||
"Bind variables according to VARLIST and conditionally evaluate BODY.
|
||||
Like `when-let*', except if BODY is empty and all the bindings
|
||||
are non-nil, then the result is non-nil."
|
||||
:feature 'subr-x
|
||||
(declare (indent 1) (debug if-let*))
|
||||
(let ((empty (make-symbol "s"))
|
||||
(last t) list)
|
||||
(dolist (var varlist)
|
||||
(push `(,(if (cdr var) (car var) empty)
|
||||
(and ,last ,(or (cadr var) (car var))))
|
||||
list)
|
||||
(when (or (cdr var) (consp (car var)))
|
||||
(setq last (caar list))))
|
||||
`(let* ,(nreverse list)
|
||||
(if ,(caar list) ,(macroexp-progn (or body '(t)))))))
|
||||
(compat-defvar mouse-select-region-move-to-beginning nil ;; <compat-tests:thing-at-mouse>
|
||||
"Effect of selecting a region extending backward from double click.
|
||||
Nil means keep point at the position clicked (region end);
|
||||
non-nil means move point to beginning of region.")
|
||||
|
||||
;;;; Defined in image.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun image-property (image property)
|
||||
(compat-defun image-property (image property) ;; <compat-tests:image-property>
|
||||
"Return the value of PROPERTY in IMAGE.
|
||||
Properties can be set with
|
||||
|
||||
(setf (image-property IMAGE PROPERTY) VALUE)
|
||||
|
||||
If VALUE is nil, PROPERTY is removed from IMAGE."
|
||||
:feature image
|
||||
(plist-get (cdr image) property))
|
||||
|
||||
;;* UNTESTED
|
||||
(unless (get 'image-property 'gv-expander)
|
||||
(gv-define-setter image-property (image property value)
|
||||
(let ((image* (make-symbol "image"))
|
||||
(property* (make-symbol "property"))
|
||||
(value* (make-symbol "value")))
|
||||
`(let ((,image* ,image)
|
||||
(,property* ,property)
|
||||
(,value* ,value))
|
||||
(if
|
||||
(null ,value*)
|
||||
(while
|
||||
(cdr ,image*)
|
||||
(if
|
||||
(eq
|
||||
(cadr ,image*)
|
||||
,property*)
|
||||
(setcdr ,image*
|
||||
(cdddr ,image*))
|
||||
(setq ,image*
|
||||
(cddr ,image*))))
|
||||
(setcdr ,image*
|
||||
(plist-put
|
||||
(cdr ,image*)
|
||||
,property* ,value*)))))))
|
||||
|
||||
;;;; Defined in rmc.el
|
||||
|
||||
;;*UNTESTED
|
||||
(compat-defun read-multiple-choice
|
||||
(prompt choices &optional _help-string _show-help long-form)
|
||||
(compat-defun read-multiple-choice (prompt choices) ;; <compat-tests:read-multiple-choice>
|
||||
"Ask user to select an entry from CHOICES, promting with PROMPT.
|
||||
This function allows to ask the user a multiple-choice question.
|
||||
|
||||
@@ -641,35 +532,23 @@ KEY is a character the user should type to select the entry.
|
||||
NAME is a short name for the entry to be displayed while prompting
|
||||
\(if there's no room, it might be shortened).
|
||||
|
||||
If LONG-FORM, do a `completing-read' over the NAME elements in
|
||||
CHOICES instead."
|
||||
:note "This is a partial implementation of `read-multiple-choice', that
|
||||
NOTE: This is a partial implementation of `read-multiple-choice', that
|
||||
among other things doesn't offer any help and ignores the
|
||||
optional DESCRIPTION field."
|
||||
(if long-form
|
||||
(let ((options (mapconcat #'cadr choices "/"))
|
||||
choice)
|
||||
(setq prompt (concat prompt " (" options "): "))
|
||||
(setq choice (completing-read prompt (mapcar #'cadr choices) nil t))
|
||||
(catch 'found
|
||||
(dolist (option choices)
|
||||
(when (string= choice (cadr option))
|
||||
(throw 'found option)))
|
||||
(error "Invalid choice")))
|
||||
(let ((options
|
||||
(mapconcat
|
||||
(lambda (opt)
|
||||
(format
|
||||
"[%s] %s"
|
||||
(key-description (string (car opt)))
|
||||
(cadr opt)))
|
||||
choices " "))
|
||||
choice)
|
||||
(setq prompt (concat prompt " (" options "): "))
|
||||
(while (not (setq choice (assq (read-char prompt) choices)))
|
||||
(message "Invalid choice")
|
||||
(sit-for 1))
|
||||
choice)))
|
||||
(let ((options
|
||||
(mapconcat
|
||||
(lambda (opt)
|
||||
(format
|
||||
"[%s] %s"
|
||||
(key-description (string (car opt)))
|
||||
(cadr opt)))
|
||||
choices " "))
|
||||
choice)
|
||||
(setq prompt (concat prompt " (" options "): "))
|
||||
(while (not (setq choice (assq (read-event prompt) choices)))
|
||||
(message "Invalid choice")
|
||||
(sit-for 1))
|
||||
choice))
|
||||
|
||||
(compat--inhibit-prefixed (provide 'compat-26))
|
||||
(provide 'compat-26)
|
||||
;;; compat-26.el ends here
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,11 +1,6 @@
|
||||
;;; compat-28.el --- Compatibility Layer for Emacs 28.1 -*- lexical-binding: t; -*-
|
||||
;;; compat-28.el --- Functionality added in Emacs 28.1 -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
|
||||
;; URL: https://git.sr.ht/~pkal/compat/
|
||||
;; Keywords: lisp
|
||||
;; 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
|
||||
@@ -22,31 +17,23 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Find here the functionality added in Emacs 28.1, needed by older
|
||||
;; versions.
|
||||
;;
|
||||
;; Only load this library if you need to use one of the following
|
||||
;; functions:
|
||||
;;
|
||||
;; - `unlock-buffer'
|
||||
;; - `string-width'
|
||||
;; - `directory-files'
|
||||
;; - `json-serialize'
|
||||
;; - `json-insert'
|
||||
;; - `json-parse-string'
|
||||
;; - `json-parse-buffer'
|
||||
;; - `count-windows'
|
||||
;; Functionality added in Emacs 28.1, needed by older Emacs versions.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'compat-macs "compat-macs.el")
|
||||
(eval-when-compile (load "compat-macs.el" nil t t))
|
||||
(compat-require compat-27 "27.1")
|
||||
|
||||
(compat-declare-version "28.1")
|
||||
(compat-version "28.1")
|
||||
|
||||
;;;; Defined in comp.c
|
||||
|
||||
(compat-defalias native-comp-available-p ignore) ;; <compat-tests:native-comp-available-p>
|
||||
|
||||
;;;; Defined in fns.c
|
||||
|
||||
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions
|
||||
(compat-defun string-search (needle haystack &optional start-pos)
|
||||
;; 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
|
||||
@@ -56,8 +43,9 @@ 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
|
||||
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."
|
||||
@@ -68,7 +56,7 @@ issues are inherited."
|
||||
(let ((case-fold-search nil))
|
||||
(string-match (regexp-quote needle) haystack start-pos))))
|
||||
|
||||
(compat-defun length= (sequence length)
|
||||
(compat-defun length= (sequence length) ;; [[compat-tests:length=]]
|
||||
"Returns non-nil if SEQUENCE has a length equal to LENGTH."
|
||||
(cond
|
||||
((null sequence) (zerop length))
|
||||
@@ -80,7 +68,7 @@ issues are inherited."
|
||||
(= (length sequence) length))
|
||||
((signal 'wrong-type-argument sequence))))
|
||||
|
||||
(compat-defun length< (sequence length)
|
||||
(compat-defun length< (sequence length) ;; [[compat-tests:length<]]
|
||||
"Returns non-nil if SEQUENCE is shorter than LENGTH."
|
||||
(cond
|
||||
((null sequence) (not (zerop length)))
|
||||
@@ -90,7 +78,7 @@ issues are inherited."
|
||||
(< (length sequence) length))
|
||||
((signal 'wrong-type-argument sequence))))
|
||||
|
||||
(compat-defun length> (sequence length)
|
||||
(compat-defun length> (sequence length) ;; [[compat-tests:length>]]
|
||||
"Returns non-nil if SEQUENCE is longer than LENGTH."
|
||||
(cond
|
||||
((listp sequence)
|
||||
@@ -101,62 +89,36 @@ issues are inherited."
|
||||
|
||||
;;;; Defined in fileio.c
|
||||
|
||||
(compat-defun file-name-concat (directory &rest components)
|
||||
(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 ((seperator (eval-when-compile
|
||||
(let ((separator (eval-when-compile
|
||||
(if (memq system-type '(ms-dos windows-nt cygwin))
|
||||
"\\" "/")))
|
||||
(last (if components (car (last components)) directory)))
|
||||
(mapconcat (lambda (part)
|
||||
(if (eq part last) ;the last component is not modified
|
||||
last
|
||||
(replace-regexp-in-string
|
||||
(concat seperator "+\\'") "" part)))
|
||||
(cons directory components)
|
||||
seperator)))
|
||||
(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
|
||||
|
||||
;;* UNTESTED (but also not necessary)
|
||||
(compat-defun garbage-collect-maybe (_factor)
|
||||
"Call ‘garbage-collect’ if enough allocation happened.
|
||||
FACTOR determines what \"enough\" means here: If FACTOR is a
|
||||
positive number N, it means to run GC if more than 1/Nth of the
|
||||
allocations needed to trigger automatic allocation took place.
|
||||
Therefore, as N gets higher, this is more likely to perform a GC.
|
||||
Returns non-nil if GC happened, and nil otherwise."
|
||||
:note "For releases of Emacs before version 28, this function will do nothing."
|
||||
;; Do nothing
|
||||
nil)
|
||||
|
||||
;;;; Defined in filelock.c
|
||||
|
||||
(compat-defun unlock-buffer ()
|
||||
"Handle `file-error' conditions:
|
||||
|
||||
Handles file system errors by calling ‘display-warning’ and
|
||||
continuing as if the error did not occur."
|
||||
:prefix t
|
||||
(condition-case error
|
||||
(unlock-buffer)
|
||||
(file-error
|
||||
(display-warning
|
||||
'(unlock-file)
|
||||
(message "%s, ignored" (error-message-string error))
|
||||
:warning))))
|
||||
(compat-defalias garbage-collect-maybe ignore) ;; <compat-tests:garbage-collect-maybe>
|
||||
|
||||
;;;; Defined in characters.c
|
||||
|
||||
(compat-defun string-width (string &optional from to)
|
||||
"Handle optional arguments FROM and TO:
|
||||
|
||||
Optional arguments FROM and TO specify the substring of STRING to
|
||||
consider, and are interpreted as in `substring'."
|
||||
:prefix t
|
||||
(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)))
|
||||
@@ -166,80 +128,25 @@ consider, and are interpreted as in `substring'."
|
||||
|
||||
;;;; Defined in dired.c
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun directory-files (directory &optional full match nosort count)
|
||||
"Handle additional optional argument COUNT:
|
||||
|
||||
If COUNT is non-nil and a natural number, the function will
|
||||
return COUNT number of file names (if so many are present)."
|
||||
:prefix t
|
||||
(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))
|
||||
|
||||
;;;; Defined in json.c
|
||||
|
||||
(declare-function json-insert nil (object &rest args))
|
||||
(declare-function json-serialize nil (object &rest args))
|
||||
(declare-function json-parse-string nil (string &rest args))
|
||||
(declare-function json-parse-buffer nil (&rest args))
|
||||
|
||||
(compat-defun json-serialize (object &rest args)
|
||||
"Handle top-level JSON values."
|
||||
:prefix t
|
||||
:min-version "27"
|
||||
(if (or (listp object) (vectorp object))
|
||||
(apply #'json-serialize object args)
|
||||
(substring (json-serialize (list object)) 1 -1)))
|
||||
|
||||
(compat-defun json-insert (object &rest args)
|
||||
"Handle top-level JSON values."
|
||||
:prefix t
|
||||
:min-version "27"
|
||||
(if (or (listp object) (vectorp object))
|
||||
(apply #'json-insert object args)
|
||||
;; `compat-json-serialize' is not sharp-quoted as the byte
|
||||
;; compiled doesn't always know that the function has been
|
||||
;; defined, but it will only be used in this function if the
|
||||
;; prefixed definition of `json-serialize' (see above) has also
|
||||
;; been defined.
|
||||
(insert (apply 'compat-json-serialize object args))))
|
||||
|
||||
(compat-defun json-parse-string (string &rest args)
|
||||
"Handle top-level JSON values."
|
||||
:prefix t
|
||||
:min-version "27"
|
||||
(if (string-match-p "\\`[[:space:]]*[[{]" string)
|
||||
(apply #'json-parse-string string args)
|
||||
;; Wrap the string in an array, and extract the value back using
|
||||
;; `elt', to ensure that no matter what the value of `:array-type'
|
||||
;; is we can access the first element.
|
||||
(elt (apply #'json-parse-string (concat "[" string "]") args) 0)))
|
||||
|
||||
(compat-defun json-parse-buffer (&rest args)
|
||||
"Handle top-level JSON values."
|
||||
:prefix t
|
||||
:min-version "27"
|
||||
(if (looking-at-p "[[:space:]]*[[{]")
|
||||
(apply #'json-parse-buffer args)
|
||||
(catch 'escape
|
||||
(atomic-change-group
|
||||
(with-syntax-table
|
||||
(let ((st (make-syntax-table)))
|
||||
(modify-syntax-entry ?\" "\"" st)
|
||||
(modify-syntax-entry ?. "_" st)
|
||||
st)
|
||||
(let ((inhibit-read-only t))
|
||||
(save-excursion
|
||||
(insert "[")
|
||||
(forward-sexp 1)
|
||||
(insert "]"))))
|
||||
(throw 'escape (elt (apply #'json-parse-buffer args) 0))))))
|
||||
(compat-defun directory-files-and-attributes (directory &optional full match nosort id-format count) ;; <compat-tests:directory-files-and-attributes>
|
||||
"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-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:
|
||||
|
||||
@@ -313,10 +220,50 @@ and BLUE, is normalized to have its value in [0,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."
|
||||
(if (display-graphic-p)
|
||||
(if length
|
||||
(concat (propertize (make-string length ?\s) 'face '(:underline t)) "\n")
|
||||
(propertize "\n" 'face '(:extend t :height 0.1 :inverse-video t)))
|
||||
(concat (make-string (or length (1- (window-width))) ?-) "\n")))
|
||||
|
||||
;;;; Defined in subr.el
|
||||
|
||||
;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions
|
||||
(compat-defun string-replace (fromstring tostring instring)
|
||||
(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)))
|
||||
@@ -326,14 +273,13 @@ and BLUE, is normalized to have its value in [0,65535]."
|
||||
tostring instring
|
||||
t t)))
|
||||
|
||||
(compat-defun always (&rest _arguments)
|
||||
(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)
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun insert-into-buffer (buffer &optional start end)
|
||||
(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."
|
||||
@@ -341,8 +287,7 @@ Point in BUFFER will be placed after the inserted text."
|
||||
(with-current-buffer buffer
|
||||
(insert-buffer-substring current start end))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun replace-string-in-region (string replacement &optional 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.
|
||||
@@ -359,18 +304,19 @@ Comparisons and replacements are done with fixed case."
|
||||
(error "End after end of buffer"))
|
||||
(setq end (point-max)))
|
||||
(save-excursion
|
||||
(let ((matches 0)
|
||||
(case-fold-search nil))
|
||||
(goto-char start)
|
||||
(while (search-forward string end t)
|
||||
(delete-region (match-beginning 0) (match-end 0))
|
||||
(insert replacement)
|
||||
(setq matches (1+ matches)))
|
||||
(and (not (zerop matches))
|
||||
matches))))
|
||||
(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)))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun replace-regexp-in-region (regexp replacement &optional start end)
|
||||
(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.
|
||||
@@ -395,17 +341,18 @@ REPLACEMENT can use the following special elements:
|
||||
(error "End after end of buffer"))
|
||||
(setq end (point-max)))
|
||||
(save-excursion
|
||||
(let ((matches 0)
|
||||
(case-fold-search nil))
|
||||
(goto-char start)
|
||||
(while (re-search-forward regexp end t)
|
||||
(replace-match replacement t)
|
||||
(setq matches (1+ matches)))
|
||||
(and (not (zerop matches))
|
||||
matches))))
|
||||
(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)))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun buffer-local-boundp (symbol buffer)
|
||||
(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
|
||||
@@ -414,26 +361,23 @@ Also see `local-variable-p'."
|
||||
(void-variable nil (throw 'fail nil)))
|
||||
t))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defmacro with-existing-directory (&rest body)
|
||||
(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 ((quit (make-symbol "with-existing-directory-quit")))
|
||||
`(catch ',quit
|
||||
(dolist (dir (list default-directory
|
||||
(expand-file-name "~/")
|
||||
(getenv "TMPDIR")
|
||||
"/tmp/"
|
||||
;; XXX: check if "/" works on non-POSIX
|
||||
;; system.
|
||||
"/"))
|
||||
(when (and dir (file-exists-p dir))
|
||||
(throw ',quit (let ((default-directory dir))
|
||||
,@body)))))))
|
||||
`(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))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defmacro dlet (binders &rest body)
|
||||
(compat-defmacro dlet (binders &rest body) ;; <compat-tests:dlet>
|
||||
"Like `let' but using dynamic scoping."
|
||||
(declare (indent 1) (debug let))
|
||||
`(let (_)
|
||||
@@ -442,7 +386,7 @@ If `default-directory' is already an existing directory, it's not changed."
|
||||
binders)
|
||||
(let ,binders ,@body)))
|
||||
|
||||
(compat-defun ensure-list (object)
|
||||
(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."
|
||||
@@ -450,18 +394,19 @@ not a list, return a one-element list containing OBJECT."
|
||||
object
|
||||
(list object)))
|
||||
|
||||
(compat-defun subr-primitive-p (object)
|
||||
"Return t if OBJECT is a built-in primitive function."
|
||||
(subrp 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-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."
|
||||
:feature 'subr-x
|
||||
(let ((blank "[[:blank:]\r\n]+"))
|
||||
(replace-regexp-in-string
|
||||
"^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$"
|
||||
@@ -469,12 +414,11 @@ removed."
|
||||
(replace-regexp-in-string
|
||||
blank " " string))))
|
||||
|
||||
(compat-defun string-fill (string length)
|
||||
(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."
|
||||
:feature 'subr-x
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(goto-char (point-min))
|
||||
@@ -483,13 +427,7 @@ removed."
|
||||
(fill-region (point-min) (point-max)))
|
||||
(buffer-string)))
|
||||
|
||||
(compat-defun string-lines (string &optional omit-nulls)
|
||||
"Split STRING into a list of lines.
|
||||
If OMIT-NULLS, empty lines will be removed from the results."
|
||||
:feature 'subr-x
|
||||
(split-string string "\n" omit-nulls))
|
||||
|
||||
(compat-defun string-pad (string length &optional padding start)
|
||||
(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.
|
||||
@@ -500,7 +438,6 @@ 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."
|
||||
:feature 'subr-x
|
||||
(unless (natnump length)
|
||||
(signal 'wrong-type-argument (list 'natnump length)))
|
||||
(let ((pad-length (- length (length string))))
|
||||
@@ -512,20 +449,18 @@ the string."
|
||||
(and (not start)
|
||||
(make-string pad-length (or padding ?\s)))))))
|
||||
|
||||
(compat-defun string-chop-newline (string)
|
||||
(compat-defun string-chop-newline (string) ;; <compat-tests:string-chop-newline>
|
||||
"Remove the final newline (if any) from STRING."
|
||||
:feature 'subr-x
|
||||
(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-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."
|
||||
:feature 'subr-x
|
||||
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
|
||||
(let ((fargs (mapcar (lambda (b)
|
||||
(let ((var (if (consp b) (car b) b)))
|
||||
@@ -596,10 +531,9 @@ as the new values of the bound variables in the recursive invocation."
|
||||
sets))
|
||||
(cons 'setq (apply #'nconc (nreverse sets)))))
|
||||
(`(throw ',quit ,expr))))))
|
||||
(let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body)))))
|
||||
(when tco-body
|
||||
(setq body `((catch ',quit
|
||||
(while t (let ,rargs ,@(macroexp-unprogn tco-body))))))))
|
||||
(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)
|
||||
@@ -609,9 +543,7 @@ as the new values of the bound variables in the recursive invocation."
|
||||
|
||||
;;;; Defined in files.el
|
||||
|
||||
(declare-function compat--string-trim-left "compat-26" (string &optional regexp))
|
||||
(declare-function compat--directory-name-p "compat-25" (name))
|
||||
(compat-defun file-name-with-extension (filename extension)
|
||||
(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 \".\".
|
||||
|
||||
@@ -622,19 +554,18 @@ 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 (compat--string-trim-left extension "[.]")))
|
||||
(let ((extn (string-remove-prefix "." extension)))
|
||||
(cond
|
||||
((string= filename "")
|
||||
(error "Empty filename"))
|
||||
((string= extn "")
|
||||
(error "Malformed extension: %s" extension))
|
||||
((compat--directory-name-p filename)
|
||||
((directory-name-p filename)
|
||||
(error "Filename is a directory: %s" filename))
|
||||
(t
|
||||
(concat (file-name-sans-extension filename) "." extn)))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun directory-empty-p (dir)
|
||||
(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.
|
||||
@@ -644,7 +575,7 @@ 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-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,
|
||||
@@ -652,7 +583,7 @@ such as `?d' for a directory, or `?l' for a symbolic link and will override
|
||||
the leading `-' char."
|
||||
(string
|
||||
(or filetype
|
||||
(pcase (lsh mode -12)
|
||||
(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).
|
||||
@@ -682,8 +613,7 @@ the leading `-' char."
|
||||
(if (zerop (logand 1 mode)) ?- ?x)
|
||||
(if (zerop (logand 1 mode)) ?T ?t))))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun file-backup-file-names (filename)
|
||||
(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."
|
||||
@@ -702,7 +632,7 @@ recent files are first."
|
||||
(push candidate files))))
|
||||
(sort files #'file-newer-than-file-p)))
|
||||
|
||||
(compat-defun make-lock-file-name (filename)
|
||||
(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
|
||||
@@ -712,21 +642,9 @@ onwards does."
|
||||
".#" (file-name-nondirectory filename))
|
||||
(file-name-directory filename)))
|
||||
|
||||
;;;; Defined in files-x.el
|
||||
|
||||
(declare-function tramp-tramp-file-p "tramp" (name))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun null-device ()
|
||||
"Return the best guess for the null device."
|
||||
(require 'tramp)
|
||||
(if (tramp-tramp-file-p default-directory)
|
||||
"/dev/null"
|
||||
null-device))
|
||||
|
||||
;;;; Defined in minibuffer.el
|
||||
|
||||
(compat-defun format-prompt (prompt default &rest format-args)
|
||||
(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
|
||||
@@ -751,15 +669,56 @@ is included in the return value."
|
||||
default)))
|
||||
": "))
|
||||
|
||||
;;;; Defined in windows.el
|
||||
;;;; Defined in faces.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun count-windows (&optional minibuf all-frames)
|
||||
"Handle optional argument ALL-FRAMES:
|
||||
(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)
|
||||
|
||||
If ALL-FRAMES is non-nil, count the windows in all frames instead
|
||||
just the selected frame."
|
||||
:prefix 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))
|
||||
@@ -770,37 +729,61 @@ just the selected frame."
|
||||
|
||||
;;;; Defined in thingatpt.el
|
||||
|
||||
(declare-function mouse-set-point "mouse" (event &optional promote-to-region))
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun thing-at-mouse (event thing &optional no-properties)
|
||||
(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."
|
||||
:feature 'thingatpt
|
||||
;; 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
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun macroexp-file-name ()
|
||||
(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."
|
||||
:feature 'macroexp
|
||||
(let ((file (car (last current-load-list))))
|
||||
(or (if (stringp file) file)
|
||||
(bound-and-true-p byte-compile-current-file))))
|
||||
|
||||
;;;; Defined in env.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defmacro with-environment-variables (variables &rest body)
|
||||
(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
|
||||
@@ -816,67 +799,56 @@ The previous values will be be restored upon exit."
|
||||
variables)
|
||||
,@body))
|
||||
|
||||
;;;; Defined in button.el
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun button-buttonize (string callback &optional data)
|
||||
"Make STRING into a button and return it.
|
||||
When clicked, CALLBACK will be called with the DATA as the
|
||||
function argument. If DATA isn't present (or is nil), the button
|
||||
itself will be used instead as the function argument."
|
||||
:feature 'button
|
||||
(propertize string
|
||||
'face 'button
|
||||
'button t
|
||||
'follow-link t
|
||||
'category t
|
||||
'button-data data
|
||||
'keymap button-map
|
||||
'action callback))
|
||||
|
||||
;;;; Defined in autoload.el
|
||||
|
||||
(defvar generated-autoload-file)
|
||||
|
||||
;;* UNTESTED
|
||||
(compat-defun make-directory-autoloads (dir output-file)
|
||||
"Update autoload definitions for Lisp files in the directories DIRS.
|
||||
DIR can be either a single directory or a list of
|
||||
directories. (The latter usage is discouraged.)
|
||||
|
||||
The autoloads will be written to OUTPUT-FILE. If any Lisp file
|
||||
binds `generated-autoload-file' as a file-local variable, write
|
||||
its autoloads into the specified file instead.
|
||||
|
||||
The function does NOT recursively descend into subdirectories of the
|
||||
directory or directories specified."
|
||||
(let ((generated-autoload-file output-file))
|
||||
;; We intentionally don't sharp-quote
|
||||
;; `update-directory-autoloads', because it was deprecated in
|
||||
;; Emacs 28 and we don't want to trigger the byte compiler for
|
||||
;; newer versions.
|
||||
(apply 'update-directory-autoloads
|
||||
(if (listp dir) dir (list dir)))))
|
||||
|
||||
;;;; Defined in time-data.el
|
||||
|
||||
(compat-defun decoded-time-period (time)
|
||||
(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
|
||||
:version "28"
|
||||
;; Inlining the definitions from compat-27
|
||||
(+ (if (consp (nth 0 time))
|
||||
;; Fractional second.
|
||||
(/ (float (car (nth 0 time)))
|
||||
(cdr (nth 0 time)))
|
||||
(or (nth 0 time) 0))
|
||||
(* (or (nth 1 time) 0) 60)
|
||||
(* (or (nth 2 time) 0) 60 60)
|
||||
(* (or (nth 3 time) 0) 60 60 24)
|
||||
(* (or (nth 4 time) 0) 60 60 24 30)
|
||||
(* (or (nth 5 time) 0) 60 60 24 365)))
|
||||
: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)))
|
||||
|
||||
(compat--inhibit-prefixed (provide 'compat-28))
|
||||
;;;; 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
|
||||
|
||||
1585
lisp/compat/compat-29.el
Normal file
1585
lisp/compat/compat-29.el
Normal file
File diff suppressed because it is too large
Load Diff
@@ -1,48 +0,0 @@
|
||||
;;; compat-font-lock.el --- -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Keywords:
|
||||
|
||||
;; 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:
|
||||
|
||||
;; Optional font-locking for `compat' definitions. Every symbol with
|
||||
;; an active compatibility definition will be highlighted.
|
||||
;;
|
||||
;; Load this file to enable the functionality.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-and-compile
|
||||
(require 'cl-lib)
|
||||
(require 'compat-macs))
|
||||
|
||||
(defvar compat-generate-common-fn)
|
||||
(let ((compat-generate-common-fn
|
||||
(lambda (name _def-fn _install-fn check-fn attr _type)
|
||||
(unless (and (plist-get attr :no-highlight)
|
||||
(funcall check-fn))
|
||||
`(font-lock-add-keywords
|
||||
'emacs-lisp-mode
|
||||
',`((,(concat "\\_<\\("
|
||||
(regexp-quote (symbol-name name))
|
||||
"\\)\\_>")
|
||||
1 font-lock-preprocessor-face prepend)))))))
|
||||
(load "compat"))
|
||||
|
||||
(provide 'compat-font-lock)
|
||||
;;; compat-font-lock.el ends here
|
||||
@@ -1,57 +0,0 @@
|
||||
;;; compat-help.el --- Documentation for compat functions -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
|
||||
;; 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:
|
||||
|
||||
;; Load this file to insert `compat'-relevant documentation next to
|
||||
;; the regular documentation of a symbol.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defun compat---describe (symbol)
|
||||
"Insert documentation for SYMBOL if it has compatibility code."
|
||||
(let ((compat (get symbol 'compat-def)))
|
||||
(when compat
|
||||
(let ((doc (get compat 'compat-doc))
|
||||
(start (point)))
|
||||
(when doc
|
||||
(insert "There is a ")
|
||||
(insert-button
|
||||
"compatibility notice"
|
||||
'action (let ((type (get compat 'compat-type)))
|
||||
(cond
|
||||
((memq type '(func macro advice))
|
||||
#'find-function)
|
||||
((memq type '(variable))
|
||||
#'find-variable)
|
||||
((error "Unknown type"))))
|
||||
'button-data compat)
|
||||
(insert (format " for %s (for versions of Emacs before %s):"
|
||||
(symbol-name symbol)
|
||||
(get compat 'compat-version)))
|
||||
(add-text-properties start (point) '(face bold))
|
||||
(newline 2)
|
||||
(insert (substitute-command-keys doc))
|
||||
(fill-region start (point))
|
||||
(newline 2))))))
|
||||
|
||||
(add-hook 'help-fns-describe-function-functions #'compat---describe)
|
||||
|
||||
(provide 'compat-help)
|
||||
;;; compat-help.el ends here
|
||||
@@ -1,9 +1,6 @@
|
||||
;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*-
|
||||
;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*-
|
||||
|
||||
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Keywords: lisp
|
||||
;; 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
|
||||
@@ -20,297 +17,249 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; These macros are used to define compatibility functions, macros and
|
||||
;; advice.
|
||||
;; This file provides *internal* macros, which are used by Compat to
|
||||
;; facilitate the definition of compatibility functions, macros and
|
||||
;; variables. The `compat-macs' feature should never be loaded at
|
||||
;; runtime in your Emacs and will only be used during byte
|
||||
;; compilation. Every definition provided here should be considered
|
||||
;; internal and may change any time between Compat releases.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defmacro compat--ignore (&rest _)
|
||||
"Ignore all arguments."
|
||||
nil)
|
||||
;; We always require subr-x at compile time for the fboundp check
|
||||
;; since definitions have been moved around. The cl-lib macros are
|
||||
;; needed by compatibility definitions.
|
||||
(require 'subr-x)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defvar compat--inhibit-prefixed nil
|
||||
"Non-nil means that prefixed definitions are not loaded.
|
||||
A prefixed function is something like `compat-assoc', that is
|
||||
only made visible when the respective compatibility version file
|
||||
is loaded (in this case `compat-26').")
|
||||
(defvar compat-macs--version nil
|
||||
"Version of the currently defined compatibility definitions.")
|
||||
|
||||
(defmacro compat--inhibit-prefixed (&rest body)
|
||||
"Ignore BODY unless `compat--inhibit-prefixed' is true."
|
||||
`(unless (bound-and-true-p compat--inhibit-prefixed)
|
||||
,@body))
|
||||
(defun compat-macs--strict (cond &rest error)
|
||||
"Assert strict COND, otherwise fail with ERROR."
|
||||
(when (bound-and-true-p compat-strict)
|
||||
(apply #'compat-macs--assert cond error)))
|
||||
|
||||
(defvar compat-current-version nil
|
||||
"Default version to use when no explicit version was given.")
|
||||
(defun compat-macs--assert (cond &rest error)
|
||||
"Assert COND, otherwise fail with ERROR."
|
||||
(unless cond (apply #'error error)))
|
||||
|
||||
(defmacro compat-declare-version (version)
|
||||
"Set the Emacs version that is currently being handled to VERSION."
|
||||
;; FIXME: Avoid setting the version for any definition that might
|
||||
;; follow, but try to restrict it to the current file/buffer.
|
||||
(setq compat-current-version version)
|
||||
nil)
|
||||
(defun compat-macs--docstring (type name docstring)
|
||||
"Format DOCSTRING for NAME of TYPE.
|
||||
Prepend compatibility notice to the actual documentation string."
|
||||
(with-temp-buffer
|
||||
(insert
|
||||
(format
|
||||
"[Compatibility %s for `%s', defined in Emacs %s. \
|
||||
See (compat) Emacs %s' for more details.]\n\n%s"
|
||||
type name compat-macs--version compat-macs--version docstring))
|
||||
(let ((fill-column 80))
|
||||
(fill-region (point-min) (point-max)))
|
||||
(buffer-string)))
|
||||
|
||||
(defvar compat--generate-function #'compat--generate-default
|
||||
"Function used to generate compatibility code.
|
||||
The function must take six arguments: NAME, DEF-FN, INSTALL-FN,
|
||||
CHECK-FN, ATTR and TYPE. The resulting body is constructed by
|
||||
invoking the functions DEF-FN (passed the \"realname\" and the
|
||||
version number, returning the compatibility definition), the
|
||||
INSTALL-FN (passed the \"realname\" and returning the
|
||||
installation code), CHECK-FN (passed the \"realname\" and
|
||||
returning a check to see if the compatibility definition should
|
||||
be installed). ATTR is a plist used to modify the generated
|
||||
code. The following attributes are handled, all others are
|
||||
ignored:
|
||||
(defun compat-macs--check-attributes (attrs preds)
|
||||
"Check ATTRS given PREDS predicate plist and return rest."
|
||||
(while (keywordp (car attrs))
|
||||
(compat-macs--assert (cdr attrs) "Attribute list length is odd")
|
||||
(compat-macs--assert (let ((p (plist-get preds (car attrs))))
|
||||
(and p (or (eq p t) (funcall p (cadr attrs)))))
|
||||
"Invalid attribute %s" (car attrs))
|
||||
(setq attrs (cddr attrs)))
|
||||
attrs)
|
||||
|
||||
- :min-version :: Prevent the compatibility definition from begin
|
||||
installed in versions older than indicated (string).
|
||||
(defun compat-macs--guard (attrs preds fun)
|
||||
"Guard compatibility definition generation.
|
||||
The version constraints specified by ATTRS are checked. PREDS is
|
||||
a plist of predicates for arguments which are passed to FUN."
|
||||
(declare (indent 2))
|
||||
(compat-macs--assert compat-macs--version "No `compat-version' was declared")
|
||||
(let* ((body (compat-macs--check-attributes
|
||||
attrs `(,@preds :feature symbolp)))
|
||||
(feature (plist-get attrs :feature))
|
||||
(attrs `(:body ,body ,@attrs))
|
||||
args)
|
||||
;; Require feature at compile time
|
||||
(when feature
|
||||
(compat-macs--assert (not (eq feature 'subr-x)) "Invalid feature subr-x")
|
||||
(require feature))
|
||||
;; The current Emacs must be older than the currently declared version.
|
||||
(when (version< emacs-version compat-macs--version)
|
||||
(while preds
|
||||
(push (plist-get attrs (car preds)) args)
|
||||
(setq preds (cddr preds)))
|
||||
(setq body (apply fun (nreverse args)))
|
||||
(if (and feature body)
|
||||
`(with-eval-after-load ',feature ,@body)
|
||||
(macroexp-progn body)))))
|
||||
|
||||
- :max-version :: Prevent the compatibility definition from begin
|
||||
installed in versions newer than indicated (string).
|
||||
(defun compat-macs--defun (type name arglist docstring rest)
|
||||
"Define function NAME of TYPE with ARGLIST and DOCSTRING.
|
||||
REST are attributes and the function BODY."
|
||||
(compat-macs--guard
|
||||
rest (list :extended (lambda (x) (or (booleanp x) (version-to-list x)))
|
||||
:obsolete (lambda (x) (or (booleanp x) (stringp x)))
|
||||
:body t)
|
||||
(lambda (extended obsolete body)
|
||||
(when (stringp extended)
|
||||
(compat-macs--assert
|
||||
(and (version< extended compat-macs--version) (version< "24.4" extended))
|
||||
"Invalid :extended version %s for %s %s" extended type name)
|
||||
(setq extended (version<= extended emacs-version)))
|
||||
(compat-macs--strict (eq extended (fboundp name))
|
||||
"Wrong :extended flag for %s %s" type name)
|
||||
;; Remove unsupported declares. It might be possible to set these
|
||||
;; properties otherwise. That should be looked into and implemented
|
||||
;; if it is the case.
|
||||
(when (and (listp (car-safe body)) (eq (caar body) 'declare) (<= emacs-major-version 25))
|
||||
(setcar body (assq-delete-all 'pure (assq-delete-all
|
||||
'side-effect-free (car body)))))
|
||||
;; Use `:extended' name if the function is already defined.
|
||||
(let* ((defname (if (and extended (fboundp name))
|
||||
(intern (format "compat--%s" name))
|
||||
name))
|
||||
(def `(,(if (memq '&key arglist)
|
||||
(if (eq type 'macro) 'cl-defmacro 'cl-defun)
|
||||
(if (eq type 'macro) 'defmacro 'defun))
|
||||
,defname ,arglist
|
||||
,(compat-macs--docstring type name docstring)
|
||||
,@body)))
|
||||
`(,@(if (eq defname name)
|
||||
;; An additional fboundp check is performed at runtime to make
|
||||
;; sure that we never redefine an existing definition if Compat
|
||||
;; is loaded on a newer Emacs version. Declare the function,
|
||||
;; such that the byte compiler does not complain about possibly
|
||||
;; missing functions at runtime. The warnings are generated due
|
||||
;; to the fboundp check.
|
||||
`((declare-function ,name nil)
|
||||
(unless (fboundp ',name) ,def))
|
||||
(list def))
|
||||
,@(when obsolete
|
||||
`((make-obsolete
|
||||
',defname ,(if (stringp obsolete) obsolete "No substitute")
|
||||
,compat-macs--version))))))))
|
||||
|
||||
- :feature :: The library the code is supposed to be loaded
|
||||
with (via `eval-after-load').
|
||||
(defmacro compat-guard (cond &rest rest)
|
||||
"Guard definition with a runtime COND and a version check.
|
||||
The runtime condition must make sure that no definition is
|
||||
overriden. REST is an attribute plist followed by the definition
|
||||
body. The attributes specify the conditions under which the
|
||||
definition is generated.
|
||||
|
||||
- :cond :: Only install the compatibility code, iff the value
|
||||
evaluates to non-nil.
|
||||
- :feature :: Wrap the definition with `with-eval-after-load' for
|
||||
the given feature."
|
||||
(declare (debug ([&rest keywordp sexp] def-body))
|
||||
(indent 1))
|
||||
(compat-macs--guard rest '(:body t)
|
||||
(lambda (body)
|
||||
(compat-macs--assert body "The guarded body is empty")
|
||||
(if (eq cond t)
|
||||
body
|
||||
(compat-macs--strict (eval cond t) "Guard %S failed" cond)
|
||||
`((when ,cond ,@body))))))
|
||||
|
||||
For prefixed functions, this can be interpreted as a test to
|
||||
`defalias' an existing definition or not.
|
||||
(defmacro compat-defalias (name def &rest attrs)
|
||||
"Define compatibility alias NAME as DEF.
|
||||
ATTRS is a plist of attributes, which specify the conditions
|
||||
under which the definition is generated.
|
||||
|
||||
- :no-highlight :: Do not highlight this definition as
|
||||
compatibility function.
|
||||
- :obsolete :: Mark the alias as obsolete if t.
|
||||
|
||||
- :version :: Manual specification of the version the compatee
|
||||
code was defined in (string).
|
||||
|
||||
- :realname :: Manual specification of a \"realname\" to use for
|
||||
the compatibility definition (symbol).
|
||||
|
||||
- :notes :: Additional notes that a developer using this
|
||||
compatibility function should keep in mind.
|
||||
|
||||
- :prefix :: Add a `compat-' prefix to the name, and define the
|
||||
compatibility code unconditionally.
|
||||
|
||||
TYPE is used to set the symbol property `compat-type' for NAME.")
|
||||
|
||||
(defun compat--generate-default (name def-fn install-fn check-fn attr type)
|
||||
"Generate a leaner compatibility definition.
|
||||
See `compat-generate-function' for details on the arguments NAME,
|
||||
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
|
||||
(let* ((min-version (plist-get attr :min-version))
|
||||
(max-version (plist-get attr :max-version))
|
||||
(feature (plist-get attr :feature))
|
||||
(cond (plist-get attr :cond))
|
||||
(version (or (plist-get attr :version)
|
||||
compat-current-version))
|
||||
(realname (or (plist-get attr :realname)
|
||||
(intern (format "compat--%S" name))))
|
||||
(check (cond
|
||||
((or (and min-version
|
||||
(version< emacs-version min-version))
|
||||
(and max-version
|
||||
(version< max-version emacs-version)))
|
||||
'(compat--ignore))
|
||||
((plist-get attr :prefix)
|
||||
'(compat--inhibit-prefixed))
|
||||
((and version (version<= version emacs-version) (not cond))
|
||||
'(compat--ignore))
|
||||
(`(when (and ,(if cond cond t)
|
||||
,(funcall check-fn)))))))
|
||||
(cond
|
||||
((and (plist-get attr :prefix) (memq type '(func macro))
|
||||
(string-match "\\`compat-\\(.+\\)\\'" (symbol-name name))
|
||||
(let* ((actual-name (intern (match-string 1 (symbol-name name))))
|
||||
(body (funcall install-fn actual-name version)))
|
||||
(when (and (version<= version emacs-version)
|
||||
(fboundp actual-name))
|
||||
`(,@check
|
||||
,(if feature
|
||||
;; See https://nullprogram.com/blog/2018/02/22/:
|
||||
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
|
||||
body))))))
|
||||
((plist-get attr :realname)
|
||||
`(progn
|
||||
,(funcall def-fn realname version)
|
||||
(,@check
|
||||
,(let ((body (funcall install-fn realname version)))
|
||||
(if feature
|
||||
;; See https://nullprogram.com/blog/2018/02/22/:
|
||||
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
|
||||
body)))))
|
||||
((let* ((body (if (eq type 'advice)
|
||||
`(,@check
|
||||
,(funcall def-fn realname version)
|
||||
,(funcall install-fn realname version))
|
||||
`(,@check ,(funcall def-fn name version)))))
|
||||
(if feature
|
||||
;; See https://nullprogram.com/blog/2018/02/22/:
|
||||
`(eval-after-load ,feature `(funcall ',(lambda () ,body)))
|
||||
body))))))
|
||||
|
||||
(defun compat-generate-common (name def-fn install-fn check-fn attr type)
|
||||
"Common code for generating compatibility definitions.
|
||||
See `compat-generate-function' for details on the arguments NAME,
|
||||
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
|
||||
(when (and (plist-get attr :cond) (plist-get attr :prefix))
|
||||
(error "A prefixed function %s cannot have a condition" name))
|
||||
(funcall compat--generate-function
|
||||
name def-fn install-fn check-fn attr type))
|
||||
|
||||
(defun compat-common-fdefine (type name arglist docstring rest)
|
||||
"Generate compatibility code for a function NAME.
|
||||
TYPE is one of `func', for functions and `macro' for macros, and
|
||||
`advice' ARGLIST is passed on directly to the definition, and
|
||||
DOCSTRING is prepended with a compatibility note. REST contains
|
||||
the remaining definition, that may begin with a property list of
|
||||
attributes (see `compat-generate-common')."
|
||||
(let ((oldname name) (body rest))
|
||||
(while (keywordp (car body))
|
||||
(setq body (cddr body)))
|
||||
;; It might be possible to set these properties otherwise. That
|
||||
;; should be looked into and implemented if it is the case.
|
||||
(when (and (listp (car-safe body)) (eq (caar body) 'declare))
|
||||
(when (version<= emacs-version "25")
|
||||
(delq (assq 'side-effect-free (car body)) (car body))
|
||||
(delq (assq 'pure (car body)) (car body))))
|
||||
;; Check if we want an explicitly prefixed function
|
||||
(when (plist-get rest :prefix)
|
||||
(setq name (intern (format "compat-%s" name))))
|
||||
(compat-generate-common
|
||||
name
|
||||
(lambda (realname version)
|
||||
`(,(cond
|
||||
((memq type '(func advice)) 'defun)
|
||||
((eq type 'macro) 'defmacro)
|
||||
((error "Unknown type")))
|
||||
,realname ,arglist
|
||||
;; Prepend compatibility notice to the actual
|
||||
;; documentation string.
|
||||
,(let ((type (cond
|
||||
((eq type 'func) "function")
|
||||
((eq type 'macro) "macro")
|
||||
((eq type 'advice) "advice")
|
||||
((error "Unknown type")))))
|
||||
(if version
|
||||
(format
|
||||
"[Compatibility %s for `%S', defined in Emacs %s]\n\n%s"
|
||||
type oldname version docstring)
|
||||
(format
|
||||
"[Compatibility %s for `%S']\n\n%s"
|
||||
type oldname docstring)))
|
||||
;; Advice may use the implicit variable `oldfun', but
|
||||
;; to avoid triggering the byte compiler, we make
|
||||
;; sure the argument is used at least once.
|
||||
,@(if (eq type 'advice)
|
||||
(cons '(ignore oldfun) body)
|
||||
body)))
|
||||
(lambda (realname _version)
|
||||
(cond
|
||||
((memq type '(func macro))
|
||||
;; Functions and macros are installed by
|
||||
;; aliasing the name of the compatible
|
||||
;; function to the name of the compatibility
|
||||
;; function.
|
||||
`(defalias ',name #',realname))
|
||||
((eq type 'advice)
|
||||
`(advice-add ',name :around #',realname))))
|
||||
(lambda ()
|
||||
(cond
|
||||
((memq type '(func macro))
|
||||
`(not (fboundp ',name)))
|
||||
((eq type 'advice) t)))
|
||||
rest type)))
|
||||
- :feature :: See `compat-guard'."
|
||||
(declare (debug (name symbolp [&rest keywordp sexp])))
|
||||
(compat-macs--guard attrs '(:obsolete booleanp)
|
||||
(lambda (obsolete)
|
||||
(compat-macs--strict (not (fboundp name)) "%s already defined" name)
|
||||
;; The fboundp check is performed at runtime to make sure that we never
|
||||
;; redefine an existing definition if Compat is loaded on a newer Emacs
|
||||
;; version.
|
||||
`((unless (fboundp ',name)
|
||||
(defalias ',name ',def
|
||||
,(compat-macs--docstring 'function name
|
||||
(get name 'function-documentation)))
|
||||
,@(when obsolete
|
||||
`((make-obsolete ',name ',def ,compat-macs--version))))))))
|
||||
|
||||
(defmacro compat-defun (name arglist docstring &rest rest)
|
||||
"Define NAME with arguments ARGLIST as a compatibility function.
|
||||
The function must be documented in DOCSTRING. REST may begin
|
||||
with a plist, that is interpreted by the macro but not passed on
|
||||
to the actual function. See `compat-generate-common' for a
|
||||
listing of attributes.
|
||||
"Define compatibility function NAME with arguments ARGLIST.
|
||||
The function must be documented in DOCSTRING. REST is an
|
||||
attribute plist followed by the function body. The attributes
|
||||
specify the conditions under which the definition is generated.
|
||||
|
||||
The definition will only be installed, if the version this
|
||||
function was defined in, as indicated by the `:version'
|
||||
attribute, is greater than the current Emacs version."
|
||||
- :extended :: Mark the function as extended if t. The function
|
||||
must be called explicitly via `compat-call'. This attribute
|
||||
should be used for functions which extend already existing
|
||||
functions, e.g., functions which changed their calling
|
||||
convention or their behavior. The value can also be a version
|
||||
string, which specifies the Emacs version when the original
|
||||
version of the function was introduced.
|
||||
|
||||
- :obsolete :: Mark the function as obsolete if t, can be a
|
||||
string describing the obsoletion.
|
||||
|
||||
- :feature :: See `compat-guard'."
|
||||
(declare (debug (&define name (&rest symbolp)
|
||||
stringp
|
||||
[&rest keywordp sexp]
|
||||
def-body))
|
||||
(doc-string 3) (indent 2))
|
||||
(compat-common-fdefine 'func name arglist docstring rest))
|
||||
(compat-macs--defun 'function name arglist docstring rest))
|
||||
|
||||
(defmacro compat-defmacro (name arglist docstring &rest rest)
|
||||
"Define NAME with arguments ARGLIST as a compatibility macro.
|
||||
The macro must be documented in DOCSTRING. REST may begin
|
||||
with a plist, that is interpreted by this macro but not passed on
|
||||
to the actual macro. See `compat-generate-common' for a
|
||||
listing of attributes.
|
||||
|
||||
The definition will only be installed, if the version this
|
||||
function was defined in, as indicated by the `:version'
|
||||
attribute, is greater than the current Emacs version."
|
||||
"Define compatibility macro NAME with arguments ARGLIST.
|
||||
The macro must be documented in DOCSTRING. REST is an attribute
|
||||
plist followed by the macro body. See `compat-defun' for
|
||||
details."
|
||||
(declare (debug compat-defun) (doc-string 3) (indent 2))
|
||||
(compat-common-fdefine 'macro name arglist docstring rest))
|
||||
(compat-macs--defun 'macro name arglist docstring rest))
|
||||
|
||||
(defmacro compat-advise (name arglist docstring &rest rest)
|
||||
"Define NAME with arguments ARGLIST as a compatibility advice.
|
||||
The advice function must be documented in DOCSTRING. REST may
|
||||
begin with a plist, that is interpreted by this macro but not
|
||||
passed on to the actual advice function. See
|
||||
`compat-generate-common' for a listing of attributes. The advice
|
||||
wraps the old definition, that is accessible via using the symbol
|
||||
`oldfun'.
|
||||
(defmacro compat-defvar (name initval docstring &rest attrs)
|
||||
"Define compatibility variable NAME with initial value INITVAL.
|
||||
The variable must be documented in DOCSTRING. ATTRS is a plist
|
||||
of attributes, which specify the conditions under which the
|
||||
definition is generated.
|
||||
|
||||
The advice will only be installed, if the version this function
|
||||
was defined in, as indicated by the `:version' attribute, is
|
||||
greater than the current Emacs version."
|
||||
(declare (debug compat-defun) (doc-string 3) (indent 2))
|
||||
(compat-common-fdefine 'advice name (cons 'oldfun arglist) docstring rest))
|
||||
- :constant :: Mark the variable as constant if t.
|
||||
|
||||
(defmacro compat-defvar (name initval docstring &rest attr)
|
||||
"Declare compatibility variable NAME with initial value INITVAL.
|
||||
The obligatory documentation string DOCSTRING must be given.
|
||||
- :local :: Make the variable buffer-local if t. If the value is
|
||||
`permanent' make the variable additionally permanently local.
|
||||
|
||||
The remaining arguments ATTR form a plist, modifying the
|
||||
behaviour of this macro. See `compat-generate-common' for a
|
||||
listing of attributes. Furthermore, `compat-defvar' also handles
|
||||
the attribute `:local' that either makes the variable permanent
|
||||
local with a value of `permanent' or just buffer local with any
|
||||
non-nil value."
|
||||
- :obsolete :: Mark the variable as obsolete if t, can be a
|
||||
string describing the obsoletion.
|
||||
|
||||
- :feature :: See `compat-guard'."
|
||||
(declare (debug (name form stringp [&rest keywordp sexp]))
|
||||
(doc-string 3) (indent 2))
|
||||
;; Check if we want an explicitly prefixed function
|
||||
(let ((oldname name))
|
||||
(when (plist-get attr :prefix)
|
||||
(setq name (intern (format "compat-%s" name))))
|
||||
(compat-generate-common
|
||||
name
|
||||
(lambda (realname version)
|
||||
(let ((localp (plist-get attr :local)))
|
||||
`(progn
|
||||
(,(if (plist-get attr :constant) 'defconst 'defvar)
|
||||
,realname ,initval
|
||||
;; Prepend compatibility notice to the actual
|
||||
;; documentation string.
|
||||
,(if version
|
||||
(format
|
||||
"[Compatibility variable for `%S', defined in Emacs %s]\n\n%s"
|
||||
oldname version docstring)
|
||||
(format
|
||||
"[Compatibility variable for `%S']\n\n%s"
|
||||
oldname docstring)))
|
||||
;; Make variable as local if necessary
|
||||
,(cond
|
||||
((eq localp 'permanent)
|
||||
`(put ',realname 'permanent-local t))
|
||||
(localp
|
||||
`(make-variable-buffer-local ',realname))))))
|
||||
(lambda (realname _version)
|
||||
`(defvaralias ',name ',realname))
|
||||
(lambda ()
|
||||
`(not (boundp ',name)))
|
||||
attr 'variable)))
|
||||
(compat-macs--guard
|
||||
attrs (list :constant #'booleanp
|
||||
:local (lambda (x) (memq x '(nil t permanent)))
|
||||
:obsolete (lambda (x) (or (booleanp x) (stringp x))))
|
||||
(lambda (constant local obsolete)
|
||||
(compat-macs--strict (not (boundp name)) "%s already defined" name)
|
||||
(compat-macs--assert (not (and constant local)) "Both :constant and :local")
|
||||
;; The boundp check is performed at runtime to make sure that we never
|
||||
;; redefine an existing definition if Compat is loaded on a newer Emacs
|
||||
;; version.
|
||||
`((unless (boundp ',name)
|
||||
(,(if constant 'defconst 'defvar)
|
||||
,name ,initval
|
||||
,(compat-macs--docstring 'variable name docstring))
|
||||
,@(when obsolete
|
||||
`((make-obsolete-variable
|
||||
',name ,(if (stringp obsolete) obsolete "No substitute")
|
||||
,compat-macs--version))))
|
||||
,@(and local `((make-variable-buffer-local ',name)))
|
||||
,@(and (eq local 'permanent) `((put ',name 'permanent-local t)))))))
|
||||
|
||||
(defmacro compat-version (version)
|
||||
"Set the Emacs version that is currently being handled to VERSION."
|
||||
(setq compat-macs--version version)
|
||||
nil)
|
||||
|
||||
(defmacro compat-require (feature version)
|
||||
"Require FEATURE if the Emacs version is less than VERSION."
|
||||
(when (version< emacs-version version)
|
||||
(require feature)
|
||||
`(require ',feature)))
|
||||
|
||||
(provide 'compat-macs)
|
||||
;;; compat-macs.el ends here
|
||||
|
||||
@@ -1,2 +1,2 @@
|
||||
;; Generated package description from compat.el -*- no-byte-compile: t -*-
|
||||
(define-package "compat" "28.1.2.2" "Emacs Lisp Compatibility Library" '((emacs "24.3") (nadvice "0.3")) :commit "d533692182c084bad623977b69f9dc298255eaab" :authors '(("Philip Kaludercic" . "philipk@posteo.net")) :maintainer '("Compat Development" . "~pkal/compat-devel@lists.sr.ht") :keywords '("lisp") :url "https://sr.ht/~pkal/compat")
|
||||
(define-package "compat" "29.1.4.2" "Emacs Lisp Compatibility Library" '((emacs "24.4") (seq "2.3")) :commit "74300f16a1630a33a86710aa20c1fc26f5f89f75" :authors '(("Philip Kaludercic" . "philipk@posteo.net") ("Daniel Mendler" . "mail@daniel-mendler.de")) :maintainer '(("Daniel Mendler" . "mail@daniel-mendler.de") ("Compat Development" . "~pkal/compat-devel@lists.sr.ht")) :keywords '("lisp" "maint") :url "https://github.com/emacs-compat/compat")
|
||||
|
||||
@@ -1,13 +1,13 @@
|
||||
;;; compat.el --- Emacs Lisp Compatibility Library -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht>
|
||||
;; Version: 28.1.2.2
|
||||
;; URL: https://sr.ht/~pkal/compat
|
||||
;; Package-Requires: ((emacs "24.3") (nadvice "0.3"))
|
||||
;; Keywords: lisp
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>, Daniel Mendler <mail@daniel-mendler.de>
|
||||
;; Maintainer: Daniel Mendler <mail@daniel-mendler.de>, Compat Development <~pkal/compat-devel@lists.sr.ht>
|
||||
;; Version: 29.1.4.2
|
||||
;; URL: https://github.com/emacs-compat/compat
|
||||
;; Package-Requires: ((emacs "24.4") (seq "2.3"))
|
||||
;; Keywords: lisp, maint
|
||||
|
||||
;; 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
|
||||
@@ -24,35 +24,70 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; To allow for the usage of Emacs functions and macros that are
|
||||
;; defined in newer versions of Emacs, compat.el provides definitions
|
||||
;; that are installed ONLY if necessary. These reimplementations of
|
||||
;; functions and macros are at least subsets of the actual
|
||||
;; implementations. Be sure to read the documentation string to make
|
||||
;; sure.
|
||||
;; Compat is the Elisp forwards compatibility library, which provides
|
||||
;; definitions introduced in newer Emacs versions. The definitions
|
||||
;; are only installed if necessary for your current Emacs version. If
|
||||
;; Compat is compiled on a recent version of Emacs, all of the
|
||||
;; definitions are disabled at compile time, such that no negative
|
||||
;; performance impact is incurred. The provided compatibility
|
||||
;; implementations of functions and macros are at least subsets of the
|
||||
;; actual implementations. Be sure to read the documentation string
|
||||
;; and the Compat manual.
|
||||
;;
|
||||
;; Not every function provided in newer versions of Emacs is provided
|
||||
;; here. Some depend on new features from the core, others cannot be
|
||||
;; implemented to a meaningful degree. Please consult the Compat
|
||||
;; manual for details. The main audience for this library are not
|
||||
;; regular users, but package maintainers. Therefore commands and
|
||||
;; user options are usually not implemented here.
|
||||
;; here. Some depend on new features from the C core, others cannot
|
||||
;; be implemented to a meaningful degree. Please consult the Compat
|
||||
;; manual for details regarding the usage of the Compat library and
|
||||
;; the provided functionality.
|
||||
|
||||
;; The main audience for this library are not regular users, but
|
||||
;; package maintainers. Therefore no commands, user-facing modes or
|
||||
;; user options are implemented here.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar compat--inhibit-prefixed)
|
||||
(let ((compat--inhibit-prefixed (not (bound-and-true-p compat-testing))))
|
||||
;; Instead of using `require', we manually check `features' and call
|
||||
;; `load' to avoid the issue of not using `provide' at the end of
|
||||
;; the file (which is disabled by `compat--inhibit-prefixed', so
|
||||
;; that the file can be loaded again at some later point when the
|
||||
;; prefixed definitions are needed).
|
||||
(dolist (vers '(24 25 26 27 28))
|
||||
(unless (memq (intern (format "compat-%d" vers)) features)
|
||||
(load (format "compat-%d%s" vers
|
||||
(if (bound-and-true-p compat-testing)
|
||||
".el" ""))
|
||||
nil t))))
|
||||
;; Ensure that the newest compatibility layer is required at compile
|
||||
;; time and runtime, but only if needed.
|
||||
(eval-when-compile
|
||||
(defmacro compat--maybe-require-29 ()
|
||||
(when (version< emacs-version "29.1")
|
||||
(require 'compat-29)
|
||||
'(require 'compat-29))))
|
||||
(compat--maybe-require-29)
|
||||
|
||||
;;;; Macros for extended compatibility function calls
|
||||
|
||||
(defmacro compat-function (fun)
|
||||
"Return compatibility function symbol for FUN.
|
||||
|
||||
If the Emacs version provides a sufficiently recent version of
|
||||
FUN, the symbol FUN is returned itself. Otherwise the macro
|
||||
returns the symbol of a compatibility function which supports the
|
||||
behavior and calling convention of the current stable Emacs
|
||||
version. For example Compat 29.1 will provide compatibility
|
||||
functions which implement the behavior and calling convention of
|
||||
Emacs 29.1.
|
||||
|
||||
See also `compat-call' to directly call compatibility functions."
|
||||
(let ((compat (intern (format "compat--%s" fun))))
|
||||
`#',(if (fboundp compat) compat fun)))
|
||||
|
||||
(defmacro compat-call (fun &rest args)
|
||||
"Call compatibility function or macro FUN with ARGS.
|
||||
|
||||
A good example function is `plist-get' which was extended with an
|
||||
additional predicate argument in Emacs 29.1. The compatibility
|
||||
function, which supports this additional argument, can be
|
||||
obtained via (compat-function plist-get) and called
|
||||
via (compat-call plist-get plist prop predicate). It is not
|
||||
possible to directly call (plist-get plist prop predicate) on
|
||||
Emacs older than 29.1, since the original `plist-get' function
|
||||
does not yet support the predicate argument. Note that the
|
||||
Compat library never overrides existing functions.
|
||||
|
||||
See also `compat-function' to lookup compatibility functions."
|
||||
(let ((compat (intern (format "compat--%s" fun))))
|
||||
`(,(if (fboundp compat) compat fun) ,@args)))
|
||||
|
||||
(provide 'compat)
|
||||
;;; compat.el ends here
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user