676 lines
24 KiB
EmacsLisp
676 lines
24 KiB
EmacsLisp
;;; compat-26.el --- Compatibility Layer for 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
|
|
|
|
;; 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 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'
|
|
|
|
;;; Code:
|
|
|
|
(require 'compat-macs "compat-macs.el")
|
|
|
|
(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))))
|
|
|
|
;;;; 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 mapcan (func sequence)
|
|
"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
|
|
(if absolute
|
|
(save-restriction
|
|
(widen)
|
|
(line-number-at-pos position))
|
|
(line-number-at-pos position)))
|
|
|
|
;;;; 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)))
|
|
|
|
(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 string-trim-left (string &optional regexp)
|
|
"Trim STRING of leading string matching REGEXP.
|
|
|
|
REGEXP defaults to \"[ \\t\\n\\r]+\"."
|
|
:realname compat--string-trim-left
|
|
:prefix 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
|
|
(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--string-trim-left
|
|
(compat--string-trim-right
|
|
string
|
|
trim-right)
|
|
trim-left))
|
|
|
|
(compat-defun caaar (x)
|
|
"Return the `car' of the `car' of the `car' of X."
|
|
(declare (pure t))
|
|
(car (car (car x))))
|
|
|
|
(compat-defun caadr (x)
|
|
"Return the `car' of the `car' of the `cdr' of X."
|
|
(declare (pure t))
|
|
(car (car (cdr x))))
|
|
|
|
(compat-defun cadar (x)
|
|
"Return the `car' of the `cdr' of the `car' of X."
|
|
(declare (pure t))
|
|
(car (cdr (car x))))
|
|
|
|
(compat-defun caddr (x)
|
|
"Return the `car' of the `cdr' of the `cdr' of X."
|
|
(declare (pure t))
|
|
(car (cdr (cdr x))))
|
|
|
|
(compat-defun cdaar (x)
|
|
"Return the `cdr' of the `car' of the `car' of X."
|
|
(declare (pure t))
|
|
(cdr (car (car x))))
|
|
|
|
(compat-defun cdadr (x)
|
|
"Return the `cdr' of the `car' of the `cdr' of X."
|
|
(declare (pure t))
|
|
(cdr (car (cdr x))))
|
|
|
|
(compat-defun cddar (x)
|
|
"Return the `cdr' of the `cdr' of the `car' of X."
|
|
(declare (pure t))
|
|
(cdr (cdr (car x))))
|
|
|
|
(compat-defun cdddr (x)
|
|
"Return the `cdr' of the `cdr' of the `cdr' of X."
|
|
(declare (pure t))
|
|
(cdr (cdr (cdr x))))
|
|
|
|
(compat-defun caaaar (x)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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
|
|
"Number used to construct the name of the next symbol created by `gensym'.")
|
|
|
|
(compat-defun gensym (&optional prefix)
|
|
"Return a new uninterned symbol.
|
|
The name is made by appending `gensym-counter' to PREFIX.
|
|
PREFIX is a string, and defaults to \"g\"."
|
|
(let ((num (prog1 gensym-counter
|
|
(setq gensym-counter
|
|
(1+ gensym-counter)))))
|
|
(make-symbol (format "%s%d" (or prefix "g") num))))
|
|
|
|
;;;; 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
|
|
(eval-when-compile
|
|
(if (memq system-type '(windows-nt cygwin))
|
|
"^//[^/]+/"
|
|
(concat
|
|
"^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))))
|
|
"File systems that ought to be mounted.")
|
|
|
|
(compat-defun file-local-name (file)
|
|
"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 ()
|
|
"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
|
|
not exist, or `default-directory' ought to be located on a
|
|
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."
|
|
(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))))
|
|
|
|
;;* UNTESTED
|
|
(compat-defun file-attribute-type (attributes)
|
|
"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)
|
|
"Return the number of links in ATTRIBUTES returned by `file-attributes'."
|
|
(nth 1 attributes))
|
|
|
|
;;* UNTESTED
|
|
(compat-defun file-attribute-user-id (attributes)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'."
|
|
(nth 7 attributes))
|
|
|
|
;;* UNTESTED
|
|
(compat-defun file-attribute-modes (attributes)
|
|
"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)
|
|
"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)
|
|
"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)
|
|
"Return a sublist of ATTRIBUTES returned by `file-attributes'.
|
|
ATTR-NAMES are symbols with the selected attribute names.
|
|
|
|
Valid attribute names are: type, link-number, user-id, group-id,
|
|
access-time, modification-time, status-change-time, size, modes,
|
|
inode-number and device-number."
|
|
(let ((idx '((type . 0)
|
|
(link-number . 1)
|
|
(user-id . 2)
|
|
(group-id . 3)
|
|
(access-time . 4)
|
|
(modification-time . 5)
|
|
(status-change-time . 6)
|
|
(size . 7)
|
|
(modes . 8)
|
|
(inode-number . 10)
|
|
(device-number . 11)))
|
|
result)
|
|
(while attr-names
|
|
(let ((attr (pop attr-names)))
|
|
(if (assq attr idx)
|
|
(push (nth (cdr (assq attr idx))
|
|
attributes)
|
|
result)
|
|
(error "Wrong attribute name '%S'" attr))))
|
|
(nreverse result)))
|
|
|
|
;;;; Defined in subr-x.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)))))))
|
|
|
|
;;;; Defined in image.el
|
|
|
|
;;* UNTESTED
|
|
(compat-defun image-property (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."
|
|
(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)
|
|
"Ask user to select an entry from CHOICES, promting with PROMPT.
|
|
This function allows to ask the user a multiple-choice question.
|
|
|
|
CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
|
|
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
|
|
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)))
|
|
|
|
(compat--inhibit-prefixed (provide 'compat-26))
|
|
;;; compat-26.el ends here
|