compat-24.el (18938B)
1 ;;; compat-24.el --- Compatibility Layer for Emacs 24.4 -*- 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 24.4, 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-=' 32 ;; - `compat-<' 33 ;; - `compat->' 34 ;; - `compat-<=' 35 ;; - `compat->=' 36 ;; - `split-string'. 37 38 ;;; Code: 39 40 (require 'compat-macs "compat-macs.el") 41 42 (compat-declare-version "24.4") 43 44 ;;;; Defined in data.c 45 46 (compat-defun = (number-or-marker &rest numbers-or-markers) 47 "Handle multiple arguments." 48 :prefix t 49 (catch 'fail 50 (while numbers-or-markers 51 (unless (= number-or-marker (car numbers-or-markers)) 52 (throw 'fail nil)) 53 (setq number-or-marker (pop numbers-or-markers))) 54 t)) 55 56 (compat-defun < (number-or-marker &rest numbers-or-markers) 57 "Handle multiple arguments." 58 :prefix t 59 (catch 'fail 60 (while numbers-or-markers 61 (unless (< number-or-marker (car numbers-or-markers)) 62 (throw 'fail nil)) 63 (setq number-or-marker (pop numbers-or-markers))) 64 t)) 65 66 (compat-defun > (number-or-marker &rest numbers-or-markers) 67 "Handle multiple arguments." 68 :prefix t 69 (catch 'fail 70 (while numbers-or-markers 71 (unless (> number-or-marker (car numbers-or-markers)) 72 (throw 'fail nil)) 73 (setq number-or-marker (pop numbers-or-markers))) 74 t)) 75 76 (compat-defun <= (number-or-marker &rest numbers-or-markers) 77 "Handle multiple arguments." 78 :prefix t 79 (catch 'fail 80 (while numbers-or-markers 81 (unless (<= number-or-marker (car numbers-or-markers)) 82 (throw 'fail nil)) 83 (setq number-or-marker (pop numbers-or-markers))) 84 t)) 85 86 (compat-defun >= (number-or-marker &rest numbers-or-markers) 87 "Handle multiple arguments." 88 :prefix t 89 (catch 'fail 90 (while numbers-or-markers 91 (unless (>= number-or-marker (pop numbers-or-markers)) 92 (throw 'fail nil))) 93 t)) 94 95 (compat-defun bool-vector-exclusive-or (a b &optional c) 96 "Return A ^ B, bitwise exclusive or. 97 If optional third argument C is given, store result into C. 98 A, B, and C must be bool vectors of the same length. 99 Return the destination vector if it changed or nil otherwise." 100 (unless (bool-vector-p a) 101 (signal 'wrong-type-argument (list 'bool-vector-p a))) 102 (unless (bool-vector-p b) 103 (signal 'wrong-type-argument (list 'bool-vector-p b))) 104 (unless (or (null c) (bool-vector-p c)) 105 (signal 'wrong-type-argument (list 'bool-vector-p c))) 106 (when (/= (length a) (length b)) 107 (signal 'wrong-length-argument (list (length a) (length b)))) 108 (let ((dest (or c (make-bool-vector (length a) nil))) changed) 109 (when (/= (length a) (length dest)) 110 (signal 'wrong-length-argument (list (length a) (length dest)))) 111 (dotimes (i (length dest)) 112 (let ((val (not (eq (aref a i) (aref b i))))) 113 (unless (eq val (aref dest i)) 114 (setq changed t)) 115 (aset dest i val))) 116 (if c (and changed c) dest))) 117 118 (compat-defun bool-vector-union (a b &optional c) 119 "Return A | B, bitwise or. 120 If optional third argument C is given, store result into C. 121 A, B, and C must be bool vectors of the same length. 122 Return the destination vector if it changed or nil otherwise." 123 (unless (bool-vector-p a) 124 (signal 'wrong-type-argument (list 'bool-vector-p a))) 125 (unless (bool-vector-p b) 126 (signal 'wrong-type-argument (list 'bool-vector-p b))) 127 (unless (or (null c) (bool-vector-p c)) 128 (signal 'wrong-type-argument (list 'bool-vector-p c))) 129 (when (/= (length a) (length b)) 130 (signal 'wrong-length-argument (list (length a) (length b)))) 131 (let ((dest (or c (make-bool-vector (length a) nil))) changed) 132 (when (/= (length a) (length dest)) 133 (signal 'wrong-length-argument (list (length a) (length dest)))) 134 (dotimes (i (length dest)) 135 (let ((val (or (aref a i) (aref b i)))) 136 (unless (eq val (aref dest i)) 137 (setq changed t)) 138 (aset dest i val))) 139 (if c (and changed c) dest))) 140 141 (compat-defun bool-vector-intersection (a b &optional c) 142 "Return A & B, bitwise and. 143 If optional third argument C is given, store result into C. 144 A, B, and C must be bool vectors of the same length. 145 Return the destination vector if it changed or nil otherwise." 146 (unless (bool-vector-p a) 147 (signal 'wrong-type-argument (list 'bool-vector-p a))) 148 (unless (bool-vector-p b) 149 (signal 'wrong-type-argument (list 'bool-vector-p b))) 150 (unless (or (null c) (bool-vector-p c)) 151 (signal 'wrong-type-argument (list 'bool-vector-p c))) 152 (when (/= (length a) (length b)) 153 (signal 'wrong-length-argument (list (length a) (length b)))) 154 (let ((dest (or c (make-bool-vector (length a) nil))) changed) 155 (when (/= (length a) (length dest)) 156 (signal 'wrong-length-argument (list (length a) (length dest)))) 157 (dotimes (i (length dest)) 158 (let ((val (and (aref a i) (aref b i)))) 159 (unless (eq val (aref dest i)) 160 (setq changed t)) 161 (aset dest i val))) 162 (if c (and changed c) dest))) 163 164 (compat-defun bool-vector-set-difference (a b &optional c) 165 "Return A &~ B, set difference. 166 If optional third argument C is given, store result into C. 167 A, B, and C must be bool vectors of the same length. 168 Return the destination vector if it changed or nil otherwise." 169 (unless (bool-vector-p a) 170 (signal 'wrong-type-argument (list 'bool-vector-p a))) 171 (unless (bool-vector-p b) 172 (signal 'wrong-type-argument (list 'bool-vector-p b))) 173 (unless (or (null c) (bool-vector-p c)) 174 (signal 'wrong-type-argument (list 'bool-vector-p c))) 175 (when (/= (length a) (length b)) 176 (signal 'wrong-length-argument (list (length a) (length b)))) 177 (let ((dest (or c (make-bool-vector (length a) nil))) changed) 178 (when (/= (length a) (length dest)) 179 (signal 'wrong-length-argument (list (length a) (length dest)))) 180 (dotimes (i (length dest)) 181 (let ((val (and (aref a i) (not (aref b i))))) 182 (unless (eq val (aref dest i)) 183 (setq changed t)) 184 (aset dest i val))) 185 (if c (and changed c) dest))) 186 187 (compat-defun bool-vector-not (a &optional b) 188 "Compute ~A, set complement. 189 If optional second argument B is given, store result into B. 190 A and B must be bool vectors of the same length. 191 Return the destination vector." 192 (unless (bool-vector-p a) 193 (signal 'wrong-type-argument (list 'bool-vector-p a))) 194 (unless (or (null b) (bool-vector-p b)) 195 (signal 'wrong-type-argument (list 'bool-vector-p b))) 196 (let ((dest (or b (make-bool-vector (length a) nil)))) 197 (when (/= (length a) (length dest)) 198 (signal 'wrong-length-argument (list (length a) (length dest)))) 199 (dotimes (i (length dest)) 200 (aset dest i (not (aref a i)))) 201 dest)) 202 203 (compat-defun bool-vector-subsetp (a b) 204 "Return t if every t value in A is also t in B, nil otherwise. 205 A and B must be bool vectors of the same length." 206 (unless (bool-vector-p a) 207 (signal 'wrong-type-argument (list 'bool-vector-p a))) 208 (unless (bool-vector-p b) 209 (signal 'wrong-type-argument (list 'bool-vector-p b))) 210 (when (/= (length a) (length b)) 211 (signal 'wrong-length-argument (list (length a) (length b)))) 212 (catch 'not-subset 213 (dotimes (i (length a)) 214 (when (if (aref a i) (not (aref b i)) nil) 215 (throw 'not-subset nil))) 216 t)) 217 218 (compat-defun bool-vector-count-consecutive (a b i) 219 "Count how many consecutive elements in A equal B starting at I. 220 A is a bool vector, B is t or nil, and I is an index into A." 221 (unless (bool-vector-p a) 222 (signal 'wrong-type-argument (list 'bool-vector-p a))) 223 (setq b (and b t)) ;normalise to nil or t 224 (unless (< i (length a)) 225 (signal 'args-out-of-range (list a i))) 226 (let ((len (length a)) (n i)) 227 (while (and (< i len) (eq (aref a i) b)) 228 (setq i (1+ i))) 229 (- i n))) 230 231 (compat-defun bool-vector-count-population (a) 232 "Count how many elements in A are t. 233 A is a bool vector. To count A's nil elements, subtract the 234 return value from A's length." 235 (unless (bool-vector-p a) 236 (signal 'wrong-type-argument (list 'bool-vector-p a))) 237 (let ((n 0)) 238 (dotimes (i (length a)) 239 (when (aref a i) 240 (setq n (1+ n)))) 241 n)) 242 243 ;;;; Defined in subr.el 244 245 ;;* UNTESTED 246 (compat-defmacro with-eval-after-load (file &rest body) 247 "Execute BODY after FILE is loaded. 248 FILE is normally a feature name, but it can also be a file name, 249 in case that file does not provide any feature. See `eval-after-load' 250 for more details about the different forms of FILE and their semantics." 251 (declare (indent 1) (debug (form def-body))) 252 ;; See https://nullprogram.com/blog/2018/02/22/ on how 253 ;; `eval-after-load' is used to preserve compatibility with 24.3. 254 `(eval-after-load ,file `(funcall ',,`(lambda () ,@body)))) 255 256 (compat-defun special-form-p (object) 257 "Non-nil if and only if OBJECT is a special form." 258 (if (and (symbolp object) (fboundp object)) 259 (setq object (condition-case nil 260 (indirect-function object) 261 (void-function nil)))) 262 (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) 263 264 (compat-defun macrop (object) 265 "Non-nil if and only if OBJECT is a macro." 266 (let ((def (condition-case nil 267 (indirect-function object) 268 (void-function nil)))) 269 (when (consp def) 270 (or (eq 'macro (car def)) 271 (and (autoloadp def) (memq (nth 4 def) '(macro t))))))) 272 273 (compat-defun string-suffix-p (suffix string &optional ignore-case) 274 "Return non-nil if SUFFIX is a suffix of STRING. 275 If IGNORE-CASE is non-nil, the comparison is done without paying 276 attention to case differences." 277 (let ((start-pos (- (length string) (length suffix)))) 278 (and (>= start-pos 0) 279 (eq t (compare-strings suffix nil nil 280 string start-pos nil ignore-case))))) 281 282 (compat-defun split-string (string &optional separators omit-nulls trim) 283 "Extend `split-string' by a TRIM argument. 284 The remaining arguments STRING, SEPARATORS and OMIT-NULLS are 285 handled just as with `split-string'." 286 :prefix t 287 (let* ((token (split-string string separators omit-nulls)) 288 (trimmed (if trim 289 (mapcar 290 (lambda (token) 291 (when (string-match (concat "\\`" trim) token) 292 (setq token (substring token (match-end 0)))) 293 (when (string-match (concat trim "\\'") token) 294 (setq token (substring token 0 (match-beginning 0)))) 295 token) 296 token) 297 token))) 298 (if omit-nulls (delete "" trimmed) trimmed))) 299 300 (compat-defun delete-consecutive-dups (list &optional circular) 301 "Destructively remove `equal' consecutive duplicates from LIST. 302 First and last elements are considered consecutive if CIRCULAR is 303 non-nil." 304 (let ((tail list) last) 305 (while (cdr tail) 306 (if (equal (car tail) (cadr tail)) 307 (setcdr tail (cddr tail)) 308 (setq last tail 309 tail (cdr tail)))) 310 (if (and circular 311 last 312 (equal (car tail) (car list))) 313 (setcdr last nil))) 314 list) 315 316 ;;* UNTESTED 317 (compat-defun define-error (name message &optional parent) 318 "Define NAME as a new error signal. 319 MESSAGE is a string that will be output to the echo area if such an error 320 is signaled without being caught by a `condition-case'. 321 PARENT is either a signal or a list of signals from which it inherits. 322 Defaults to `error'." 323 (unless parent (setq parent 'error)) 324 (let ((conditions 325 (if (consp parent) 326 (apply #'append 327 (mapcar (lambda (parent) 328 (cons parent 329 (or (get parent 'error-conditions) 330 (error "Unknown signal `%s'" parent)))) 331 parent)) 332 (cons parent (get parent 'error-conditions))))) 333 (put name 'error-conditions 334 (delete-dups (copy-sequence (cons name conditions)))) 335 (when message (put name 'error-message message)))) 336 337 ;;;; Defined in minibuffer.el 338 339 ;;* UNTESTED 340 (compat-defun completion-table-with-cache (fun &optional ignore-case) 341 "Create dynamic completion table from function FUN, with cache. 342 This is a wrapper for `completion-table-dynamic' that saves the last 343 argument-result pair from FUN, so that several lookups with the 344 same argument (or with an argument that starts with the first one) 345 only need to call FUN once. This can be useful when FUN performs a 346 relatively slow operation, such as calling an external process. 347 348 When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive." 349 (let* (last-arg last-result 350 (new-fun 351 (lambda (arg) 352 (if (and last-arg (string-prefix-p last-arg arg ignore-case)) 353 last-result 354 (prog1 355 (setq last-result (funcall fun arg)) 356 (setq last-arg arg)))))) 357 (completion-table-dynamic new-fun))) 358 359 ;;* UNTESTED 360 (compat-defun completion-table-merge (&rest tables) 361 "Create a completion table that collects completions from all TABLES." 362 (lambda (string pred action) 363 (cond 364 ((null action) 365 (let ((retvals (mapcar (lambda (table) 366 (try-completion string table pred)) 367 tables))) 368 (if (member string retvals) 369 string 370 (try-completion string 371 (mapcar (lambda (value) 372 (if (eq value t) string value)) 373 (delq nil retvals)) 374 pred)))) 375 ((eq action t) 376 (apply #'append (mapcar (lambda (table) 377 (all-completions string table pred)) 378 tables))) 379 (t 380 (completion--some (lambda (table) 381 (complete-with-action action table string pred)) 382 tables))))) 383 384 ;;;; Defined in subr-x.el 385 386 ;;* UNTESTED 387 (compat-advise require (feature &rest args) 388 "Allow for Emacs 24.x to require the inexistent FEATURE subr-x." 389 ;; As the compatibility advise around `require` is more a hack than 390 ;; of of actual value, the highlighting is suppressed. 391 :no-highlight t 392 (if (eq feature 'subr-x) 393 (let ((entry (assq feature after-load-alist))) 394 (let ((load-file-name nil)) 395 (dolist (form (cdr entry)) 396 (funcall (eval form t))))) 397 (apply oldfun feature args))) 398 399 (compat-defun hash-table-keys (hash-table) 400 "Return a list of keys in HASH-TABLE." 401 (let (values) 402 (maphash 403 (lambda (k _v) (push k values)) 404 hash-table) 405 values)) 406 407 (compat-defun hash-table-values (hash-table) 408 "Return a list of values in HASH-TABLE." 409 (let (values) 410 (maphash 411 (lambda (_k v) (push v values)) 412 hash-table) 413 values)) 414 415 (compat-defun string-empty-p (string) 416 "Check whether STRING is empty." 417 (string= string "")) 418 419 (compat-defun string-join (strings &optional separator) 420 "Join all STRINGS using SEPARATOR. 421 Optional argument SEPARATOR must be a string, a vector, or a list of 422 characters; nil stands for the empty string." 423 (mapconcat #'identity strings separator)) 424 425 (compat-defun string-blank-p (string) 426 "Check whether STRING is either empty or only whitespace. 427 The following characters count as whitespace here: space, tab, newline and 428 carriage return." 429 (string-match-p "\\`[ \t\n\r]*\\'" string)) 430 431 (compat-defun string-remove-prefix (prefix string) 432 "Remove PREFIX from STRING if present." 433 (if (string-prefix-p prefix string) 434 (substring string (length prefix)) 435 string)) 436 437 (compat-defun string-remove-suffix (suffix string) 438 "Remove SUFFIX from STRING if present." 439 (if (string-suffix-p suffix string) 440 (substring string 0 (- (length string) (length suffix))) 441 string)) 442 443 ;;;; Defined in faces.el 444 445 ;;* UNTESTED 446 (compat-defun face-spec-set (face spec &optional spec-type) 447 "Set the FACE's spec SPEC, define FACE, and recalculate its attributes. 448 See `defface' for the format of SPEC. 449 450 The appearance of each face is controlled by its specs (set via 451 this function), and by the internal frame-specific face 452 attributes (set via `set-face-attribute'). 453 454 This function also defines FACE as a valid face name if it is not 455 already one, and (re)calculates its attributes on existing 456 frames. 457 458 The optional argument SPEC-TYPE determines which spec to set: 459 nil, omitted or `face-override-spec' means the override spec, 460 which overrides all the other types of spec mentioned below 461 (this is usually what you want if calling this function 462 outside of Custom code); 463 `customized-face' or `saved-face' means the customized spec or 464 the saved custom spec; 465 `face-defface-spec' means the default spec 466 (usually set only via `defface'); 467 `reset' means to ignore SPEC, but clear the `customized-face' 468 and `face-override-spec' specs; 469 Any other value means not to set any spec, but to run the 470 function for defining FACE and recalculating its attributes." 471 (if (get face 'face-alias) 472 (setq face (get face 'face-alias))) 473 ;; Save SPEC to the relevant symbol property. 474 (unless spec-type 475 (setq spec-type 'face-override-spec)) 476 (if (memq spec-type '(face-defface-spec face-override-spec 477 customized-face saved-face)) 478 (put face spec-type spec)) 479 (if (memq spec-type '(reset saved-face)) 480 (put face 'customized-face nil)) 481 ;; Setting the face spec via Custom empties out any override spec, 482 ;; similar to how setting a variable via Custom changes its values. 483 (if (memq spec-type '(customized-face saved-face reset)) 484 (put face 'face-override-spec nil)) 485 ;; If we reset the face based on its custom spec, it is unmodified 486 ;; as far as Custom is concerned. 487 (unless (eq face 'face-override-spec) 488 (put face 'face-modified nil)) 489 ;; Initialize the face if it does not exist, then recalculate. 490 (make-empty-face face) 491 (dolist (frame (frame-list)) 492 (face-spec-recalc face frame))) 493 494 (compat--inhibit-prefixed (provide 'compat-24)) 495 ;;; compat-24.el ends here