compat-25.el (11414B)
1 ;;; compat-25.el --- Compatibility Layer for Emacs 25.1 -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. 4 5 ;; Author: Philip Kaludercic <philipk@posteo.net> 6 ;; Maintainer: Compat Development <~pkal/compat-devel@lists.sr.ht> 7 ;; URL: https://git.sr.ht/~pkal/compat/ 8 ;; Keywords: lisp 9 10 ;; This program is free software; you can redistribute it and/or modify 11 ;; it under the terms of the GNU General Public License as published by 12 ;; the Free Software Foundation, either version 3 of the License, or 13 ;; (at your option) any later version. 14 15 ;; This program is distributed in the hope that it will be useful, 16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; GNU General Public License for more details. 19 20 ;; You should have received a copy of the GNU General Public License 21 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 22 23 ;;; Commentary: 24 25 ;; Find here the functionality added in Emacs 25.1, needed by older 26 ;; versions. 27 ;; 28 ;; Only load this library if you need to use one of the following 29 ;; functions: 30 ;; 31 ;; - `compat-sort' 32 33 ;;; Code: 34 35 (require 'compat-macs "compat-macs.el") 36 37 (compat-declare-version "25.1") 38 39 ;;;; Defined in alloc.c 40 41 (compat-defun bool-vector (&rest objects) 42 "Return a new bool-vector with specified arguments as elements. 43 Allows any number of arguments, including zero. 44 usage: (bool-vector &rest OBJECTS)" 45 (let ((vec (make-bool-vector (length objects) nil)) 46 (i 0)) 47 (while objects 48 (when (car objects) 49 (aset vec i t)) 50 (setq objects (cdr objects) 51 i (1+ i))) 52 vec)) 53 54 ;;;; Defined in fns.c 55 56 (compat-defun sort (seq predicate) 57 "Extend `sort' to sort SEQ as a vector." 58 :prefix t 59 (cond 60 ((listp seq) 61 (sort seq predicate)) 62 ((vectorp seq) 63 (let ((cseq (sort (append seq nil) predicate))) 64 (dotimes (i (length cseq)) 65 (setf (aref seq i) (nth i cseq))) 66 (apply #'vector cseq))) 67 ((signal 'wrong-type-argument 'list-or-vector-p)))) 68 69 ;;;; Defined in editfns.c 70 71 (compat-defun format-message (string &rest objects) 72 "Format a string out of a format-string and arguments. 73 The first argument is a format control string. 74 The other arguments are substituted into it to make the result, a string. 75 76 This implementation is equivalent to `format'." 77 (apply #'format string objects)) 78 79 ;;;; Defined in minibuf.c 80 81 ;; TODO advise read-buffer to handle 4th argument 82 83 ;;;; Defined in fileio.c 84 85 (compat-defun directory-name-p (name) 86 "Return non-nil if NAME ends with a directory separator character." 87 :realname compat--directory-name-p 88 (eq (eval-when-compile 89 (if (memq system-type '(cygwin windows-nt ms-dos)) 90 ?\\ ?/)) 91 (aref name (1- (length name))))) 92 93 ;;;; Defined in subr.el 94 95 (compat-defun string-greaterp (string1 string2) 96 "Return non-nil if STRING1 is greater than STRING2 in lexicographic order. 97 Case is significant. 98 Symbols are also allowed; their print names are used instead." 99 (string-lessp string2 string1)) 100 101 ;;* UNTESTED 102 (compat-defmacro with-file-modes (modes &rest body) 103 "Execute BODY with default file permissions temporarily set to MODES. 104 MODES is as for `set-default-file-modes'." 105 (declare (indent 1) (debug t)) 106 (let ((umask (make-symbol "umask"))) 107 `(let ((,umask (default-file-modes))) 108 (unwind-protect 109 (progn 110 (set-default-file-modes ,modes) 111 ,@body) 112 (set-default-file-modes ,umask))))) 113 114 (compat-defun alist-get (key alist &optional default remove testfn) 115 "Find the first element of ALIST whose `car' equals KEY and return its `cdr'. 116 If KEY is not found in ALIST, return DEFAULT. 117 Equality with KEY is tested by TESTFN, defaulting to `eq'." 118 :realname compat--alist-get-full-elisp 119 (ignore remove) 120 (let (entry) 121 (cond 122 ((or (null testfn) (eq testfn 'eq)) 123 (setq entry (assq key alist))) 124 ((eq testfn 'equal) 125 (setq entry (assoc key alist))) 126 ((catch 'found 127 (dolist (ent alist) 128 (when (and (consp ent) (funcall testfn (car ent) key)) 129 (throw 'found (setq entry ent)))) 130 default))) 131 (if entry (cdr entry) default))) 132 133 ;;;; Defined in subr-x.el 134 135 (compat-defmacro if-let (spec then &rest else) 136 "Bind variables according to SPEC and evaluate THEN or ELSE. 137 Evaluate each binding in turn, as in `let*', stopping if a 138 binding value is nil. If all are non-nil return the value of 139 THEN, otherwise the last form in ELSE. 140 141 Each element of SPEC is a list (SYMBOL VALUEFORM) that binds 142 SYMBOL to the value of VALUEFORM. An element can additionally be 143 of the form (VALUEFORM), which is evaluated and checked for nil; 144 i.e. SYMBOL can be omitted if only the test result is of 145 interest. It can also be of the form SYMBOL, then the binding of 146 SYMBOL is checked for nil. 147 148 As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) 149 like \((SYMBOL SOMETHING)). This exists for backward compatibility 150 with an old syntax that accepted only one binding." 151 :realname compat--if-let 152 :feature 'subr-x 153 (declare (indent 2) 154 (debug ([&or (symbolp form) 155 (&rest [&or symbolp (symbolp form) (form)])] 156 body))) 157 (when (and (<= (length spec) 2) 158 (not (listp (car spec)))) 159 ;; Adjust the single binding case 160 (setq spec (list spec))) 161 `(compat--if-let* ,spec ,then ,(macroexp-progn else))) 162 163 (compat-defmacro when-let (spec &rest body) 164 "Bind variables according to SPEC and conditionally evaluate BODY. 165 Evaluate each binding in turn, stopping if a binding value is nil. 166 If all are non-nil, return the value of the last form in BODY. 167 168 The variable list SPEC is the same as in `if-let'." 169 :feature 'subr-x 170 (declare (indent 1) (debug if-let)) 171 `(compat--if-let ,spec ,(macroexp-progn body))) 172 173 (compat-defmacro thread-first (&rest forms) 174 "Thread FORMS elements as the first argument of their successor. 175 Example: 176 (thread-first 177 5 178 (+ 20) 179 (/ 25) 180 - 181 (+ 40)) 182 Is equivalent to: 183 (+ (- (/ (+ 5 20) 25)) 40) 184 Note how the single `-' got converted into a list before 185 threading." 186 :feature 'subr-x 187 (declare (indent 1) 188 (debug (form &rest [&or symbolp (sexp &rest form)]))) 189 (let ((body (car forms))) 190 (dolist (form (cdr forms)) 191 (when (symbolp form) 192 (setq form (list form))) 193 (setq body (append (list (car form)) 194 (list body) 195 (cdr form)))) 196 body)) 197 198 (compat-defmacro thread-last (&rest forms) 199 "Thread FORMS elements as the last argument of their successor. 200 Example: 201 (thread-last 202 5 203 (+ 20) 204 (/ 25) 205 - 206 (+ 40)) 207 Is equivalent to: 208 (+ 40 (- (/ 25 (+ 20 5)))) 209 Note how the single `-' got converted into a list before 210 threading." 211 :feature 'subr-x 212 (declare (indent 1) (debug thread-first)) 213 (let ((body (car forms))) 214 (dolist (form (cdr forms)) 215 (when (symbolp form) 216 (setq form (list form))) 217 (setq body (append form (list body)))) 218 body)) 219 220 ;;;; Defined in macroexp.el 221 222 (declare-function macrop nil (object)) 223 (compat-defun macroexpand-1 (form &optional environment) 224 "Perform (at most) one step of macro expansion." 225 :feature 'macroexp 226 (cond 227 ((consp form) 228 (let* ((head (car form)) 229 (env-expander (assq head environment))) 230 (if env-expander 231 (if (cdr env-expander) 232 (apply (cdr env-expander) (cdr form)) 233 form) 234 (if (not (and (symbolp head) (fboundp head))) 235 form 236 (let ((def (autoload-do-load (symbol-function head) head 'macro))) 237 (cond 238 ;; Follow alias, but only for macros, otherwise we may end up 239 ;; skipping an important compiler-macro (e.g. cl--block-wrapper). 240 ((and (symbolp def) (macrop def)) (cons def (cdr form))) 241 ((not (consp def)) form) 242 (t 243 (if (eq 'macro (car def)) 244 (apply (cdr def) (cdr form)) 245 form)))))))) 246 (t form))) 247 248 ;;;; Defined in byte-run.el 249 250 ;;* UNTESTED 251 (compat-defun function-put (func prop value) 252 "Set FUNCTION's property PROP to VALUE. 253 The namespace for PROP is shared with symbols. 254 So far, FUNCTION can only be a symbol, not a lambda expression." 255 :version "24.4" 256 (put func prop value)) 257 258 ;;;; Defined in files.el 259 260 ;;* UNTESTED 261 (compat-defun directory-files-recursively 262 (dir regexp &optional include-directories predicate follow-symlinks) 263 "Return list of all files under directory DIR whose names match REGEXP. 264 This function works recursively. Files are returned in \"depth 265 first\" order, and files from each directory are sorted in 266 alphabetical order. Each file name appears in the returned list 267 in its absolute form. 268 269 By default, the returned list excludes directories, but if 270 optional argument INCLUDE-DIRECTORIES is non-nil, they are 271 included. 272 273 PREDICATE can be either nil (which means that all subdirectories 274 of DIR are descended into), t (which means that subdirectories that 275 can't be read are ignored), or a function (which is called with 276 the name of each subdirectory, and should return non-nil if the 277 subdirectory is to be descended into). 278 279 If FOLLOW-SYMLINKS is non-nil, symbolic links that point to 280 directories are followed. Note that this can lead to infinite 281 recursion." 282 :realname compat--directory-files-recursively 283 (let* ((result nil) 284 (files nil) 285 (dir (directory-file-name dir)) 286 ;; When DIR is "/", remote file names like "/method:" could 287 ;; also be offered. We shall suppress them. 288 (tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir))))) 289 (dolist (file (sort (file-name-all-completions "" dir) 290 'string<)) 291 (unless (member file '("./" "../")) 292 (if (directory-name-p file) 293 (let* ((leaf (substring file 0 (1- (length file)))) 294 (full-file (concat dir "/" leaf))) 295 ;; Don't follow symlinks to other directories. 296 (when (and (or (not (file-symlink-p full-file)) 297 (and (file-symlink-p full-file) 298 follow-symlinks)) 299 ;; Allow filtering subdirectories. 300 (or (eq predicate nil) 301 (eq predicate t) 302 (funcall predicate full-file))) 303 (let ((sub-files 304 (if (eq predicate t) 305 (condition-case nil 306 (compat--directory-files-recursively 307 full-file regexp include-directories 308 predicate follow-symlinks) 309 (file-error nil)) 310 (compat--directory-files-recursively 311 full-file regexp include-directories 312 predicate follow-symlinks)))) 313 (setq result (nconc result sub-files)))) 314 (when (and include-directories 315 (string-match regexp leaf)) 316 (setq result (nconc result (list full-file))))) 317 (when (string-match regexp file) 318 (push (concat dir "/" file) files))))) 319 (nconc result (nreverse files)))) 320 321 (compat--inhibit-prefixed (provide 'compat-25)) 322 ;;; compat-25.el ends here