compat-28.el (33546B)
1 ;;; compat-28.el --- Compatibility Layer for Emacs 28.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 28.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 ;; - `unlock-buffer' 32 ;; - `string-width' 33 ;; - `directory-files' 34 ;; - `json-serialize' 35 ;; - `json-insert' 36 ;; - `json-parse-string' 37 ;; - `json-parse-buffer' 38 ;; - `count-windows' 39 40 ;;; Code: 41 42 (require 'compat-macs "compat-macs.el") 43 44 (compat-declare-version "28.1") 45 46 ;;;; Defined in fns.c 47 48 ;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions 49 (compat-defun string-search (needle haystack &optional start-pos) 50 "Search for the string NEEDLE in the strign HAYSTACK. 51 52 The return value is the position of the first occurrence of 53 NEEDLE in HAYSTACK, or nil if no match was found. 54 55 The optional START-POS argument says where to start searching in 56 HAYSTACK and defaults to zero (start at the beginning). 57 It must be between zero and the length of HAYSTACK, inclusive. 58 59 Case is always significant and text properties are ignored." 60 :note "Prior to Emacs 27 `string-match' has issues handling 61 multibyte regular expressions. As the compatibility function 62 for `string-search' is implemented via `string-match', these 63 issues are inherited." 64 (when (and start-pos (or (< (length haystack) start-pos) 65 (< start-pos 0))) 66 (signal 'args-out-of-range (list start-pos))) 67 (save-match-data 68 (let ((case-fold-search nil)) 69 (string-match (regexp-quote needle) haystack start-pos)))) 70 71 (compat-defun length= (sequence length) 72 "Returns non-nil if SEQUENCE has a length equal to LENGTH." 73 (cond 74 ((null sequence) (zerop length)) 75 ((consp sequence) 76 (and (null (nthcdr length sequence)) 77 (nthcdr (1- length) sequence) 78 t)) 79 ((arrayp sequence) 80 (= (length sequence) length)) 81 ((signal 'wrong-type-argument sequence)))) 82 83 (compat-defun length< (sequence length) 84 "Returns non-nil if SEQUENCE is shorter than LENGTH." 85 (cond 86 ((null sequence) (not (zerop length))) 87 ((listp sequence) 88 (null (nthcdr (1- length) sequence))) 89 ((arrayp sequence) 90 (< (length sequence) length)) 91 ((signal 'wrong-type-argument sequence)))) 92 93 (compat-defun length> (sequence length) 94 "Returns non-nil if SEQUENCE is longer than LENGTH." 95 (cond 96 ((listp sequence) 97 (and (nthcdr length sequence) t)) 98 ((arrayp sequence) 99 (> (length sequence) length)) 100 ((signal 'wrong-type-argument sequence)))) 101 102 ;;;; Defined in fileio.c 103 104 (compat-defun file-name-concat (directory &rest components) 105 "Append COMPONENTS to DIRECTORY and return the resulting string. 106 Elements in COMPONENTS must be a string or nil. 107 DIRECTORY or the non-final elements in COMPONENTS may or may not end 108 with a slash -- if they don’t end with a slash, a slash will be 109 inserted before contatenating." 110 (let ((seperator (eval-when-compile 111 (if (memq system-type '(ms-dos windows-nt cygwin)) 112 "\\" "/"))) 113 (last (if components (car (last components)) directory))) 114 (mapconcat (lambda (part) 115 (if (eq part last) ;the last component is not modified 116 last 117 (replace-regexp-in-string 118 (concat seperator "+\\'") "" part))) 119 (cons directory components) 120 seperator))) 121 122 ;;;; Defined in alloc.c 123 124 ;;* UNTESTED (but also not necessary) 125 (compat-defun garbage-collect-maybe (_factor) 126 "Call ‘garbage-collect’ if enough allocation happened. 127 FACTOR determines what \"enough\" means here: If FACTOR is a 128 positive number N, it means to run GC if more than 1/Nth of the 129 allocations needed to trigger automatic allocation took place. 130 Therefore, as N gets higher, this is more likely to perform a GC. 131 Returns non-nil if GC happened, and nil otherwise." 132 :note "For releases of Emacs before version 28, this function will do nothing." 133 ;; Do nothing 134 nil) 135 136 ;;;; Defined in filelock.c 137 138 (compat-defun unlock-buffer () 139 "Handle `file-error' conditions: 140 141 Handles file system errors by calling ‘display-warning’ and 142 continuing as if the error did not occur." 143 :prefix t 144 (condition-case error 145 (unlock-buffer) 146 (file-error 147 (display-warning 148 '(unlock-file) 149 (message "%s, ignored" (error-message-string error)) 150 :warning)))) 151 152 ;;;; Defined in characters.c 153 154 (compat-defun string-width (string &optional from to) 155 "Handle optional arguments FROM and TO: 156 157 Optional arguments FROM and TO specify the substring of STRING to 158 consider, and are interpreted as in `substring'." 159 :prefix t 160 (let* ((len (length string)) 161 (from (or from 0)) 162 (to (or to len))) 163 (if (and (= from 0) (= to len)) 164 (string-width string) 165 (string-width (substring string from to))))) 166 167 ;;;; Defined in dired.c 168 169 ;;* UNTESTED 170 (compat-defun directory-files (directory &optional full match nosort count) 171 "Handle additional optional argument COUNT: 172 173 If COUNT is non-nil and a natural number, the function will 174 return COUNT number of file names (if so many are present)." 175 :prefix t 176 (let ((files (directory-files directory full match nosort))) 177 (when (natnump count) 178 (setf (nthcdr count files) nil)) 179 files)) 180 181 ;;;; Defined in json.c 182 183 (declare-function json-insert nil (object &rest args)) 184 (declare-function json-serialize nil (object &rest args)) 185 (declare-function json-parse-string nil (string &rest args)) 186 (declare-function json-parse-buffer nil (&rest args)) 187 188 (compat-defun json-serialize (object &rest args) 189 "Handle top-level JSON values." 190 :prefix t 191 :min-version "27" 192 (if (or (listp object) (vectorp object)) 193 (apply #'json-serialize object args) 194 (substring (json-serialize (list object)) 1 -1))) 195 196 (compat-defun json-insert (object &rest args) 197 "Handle top-level JSON values." 198 :prefix t 199 :min-version "27" 200 (if (or (listp object) (vectorp object)) 201 (apply #'json-insert object args) 202 ;; `compat-json-serialize' is not sharp-quoted as the byte 203 ;; compiled doesn't always know that the function has been 204 ;; defined, but it will only be used in this function if the 205 ;; prefixed definition of `json-serialize' (see above) has also 206 ;; been defined. 207 (insert (apply 'compat-json-serialize object args)))) 208 209 (compat-defun json-parse-string (string &rest args) 210 "Handle top-level JSON values." 211 :prefix t 212 :min-version "27" 213 (if (string-match-p "\\`[[:space:]]*[[{]" string) 214 (apply #'json-parse-string string args) 215 ;; Wrap the string in an array, and extract the value back using 216 ;; `elt', to ensure that no matter what the value of `:array-type' 217 ;; is we can access the first element. 218 (elt (apply #'json-parse-string (concat "[" string "]") args) 0))) 219 220 (compat-defun json-parse-buffer (&rest args) 221 "Handle top-level JSON values." 222 :prefix t 223 :min-version "27" 224 (if (looking-at-p "[[:space:]]*[[{]") 225 (apply #'json-parse-buffer args) 226 (catch 'escape 227 (atomic-change-group 228 (with-syntax-table 229 (let ((st (make-syntax-table))) 230 (modify-syntax-entry ?\" "\"" st) 231 (modify-syntax-entry ?. "_" st) 232 st) 233 (let ((inhibit-read-only t)) 234 (save-excursion 235 (insert "[") 236 (forward-sexp 1) 237 (insert "]")))) 238 (throw 'escape (elt (apply #'json-parse-buffer args) 0)))))) 239 240 ;;;; xfaces.c 241 242 (compat-defun color-values-from-color-spec (spec) 243 "Parse color SPEC as a numeric color and return (RED GREEN BLUE). 244 This function recognises the following formats for SPEC: 245 246 #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each. 247 rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each. 248 rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1]. 249 250 If SPEC is not in one of the above forms, return nil. 251 252 Each of the 3 integer members of the resulting list, RED, GREEN, 253 and BLUE, is normalized to have its value in [0,65535]." 254 (let ((case-fold-search nil)) 255 (save-match-data 256 (cond 257 ((string-match 258 ;; (rx bos "#" 259 ;; (or (: (group-n 1 (= 1 hex)) (group-n 2 (= 1 hex)) (group-n 3 (= 1 hex))) 260 ;; (: (group-n 1 (= 2 hex)) (group-n 2 (= 2 hex)) (group-n 3 (= 2 hex))) 261 ;; (: (group-n 1 (= 3 hex)) (group-n 2 (= 3 hex)) (group-n 3 (= 3 hex))) 262 ;; (: (group-n 1 (= 4 hex)) (group-n 2 (= 4 hex)) (group-n 3 (= 4 hex)))) 263 ;; eos) 264 "\\`#\\(?:\\(?1:[[:xdigit:]]\\{1\\}\\)\\(?2:[[:xdigit:]]\\{1\\}\\)\\(?3:[[:xdigit:]]\\{1\\}\\)\\|\\(?1:[[:xdigit:]]\\{2\\}\\)\\(?2:[[:xdigit:]]\\{2\\}\\)\\(?3:[[:xdigit:]]\\{2\\}\\)\\|\\(?1:[[:xdigit:]]\\{3\\}\\)\\(?2:[[:xdigit:]]\\{3\\}\\)\\(?3:[[:xdigit:]]\\{3\\}\\)\\|\\(?1:[[:xdigit:]]\\{4\\}\\)\\(?2:[[:xdigit:]]\\{4\\}\\)\\(?3:[[:xdigit:]]\\{4\\}\\)\\)\\'" 265 spec) 266 (let ((max (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4))))) 267 (list (/ (* (string-to-number (match-string 1 spec) 16) 65535) max) 268 (/ (* (string-to-number (match-string 2 spec) 16) 65535) max) 269 (/ (* (string-to-number (match-string 3 spec) 16) 65535) max)))) 270 ((string-match 271 ;; (rx bos "rgb:" 272 ;; (group (** 1 4 hex)) "/" 273 ;; (group (** 1 4 hex)) "/" 274 ;; (group (** 1 4 hex)) 275 ;; eos) 276 "\\`rgb:\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)/\\([[:xdigit:]]\\{1,4\\}\\)\\'" 277 spec) 278 (list (/ (* (string-to-number (match-string 1 spec) 16) 65535) 279 (1- (ash 1 (* (- (match-end 1) (match-beginning 1)) 4)))) 280 (/ (* (string-to-number (match-string 2 spec) 16) 65535) 281 (1- (ash 1 (* (- (match-end 2) (match-beginning 2)) 4)))) 282 (/ (* (string-to-number (match-string 3 spec) 16) 65535) 283 (1- (ash 1 (* (- (match-end 3) (match-beginning 3)) 4)))))) 284 ;; The "RGBi" (RGB Intensity) specification is defined by 285 ;; XCMS[0], see [1] for the implementation in Xlib. 286 ;; 287 ;; [0] http://www.nic.funet.fi/pub/X11/X11R4/DOCS/color/Xcms.text 288 ;; [1] https://gitlab.freedesktop.org/xorg/lib/libx11/-/blob/master/src/xcms/LRGB.c#L1392 289 ((string-match 290 ;; (rx bos "rgbi:" (* space) 291 ;; (group (? (or "-" "+")) 292 ;; (or (: (+ digit) (? "." (* digit))) 293 ;; (: "." (+ digit))) 294 ;; (? "e" (? (or "-" "+")) (+ digit))) 295 ;; "/" (* space) 296 ;; (group (? (or "-" "+")) 297 ;; (or (: (+ digit) (? "." (* digit))) 298 ;; (: "." (+ digit))) 299 ;; (? "e" (? (or "-" "+")) (+ digit))) 300 ;; "/" (* space) 301 ;; (group (? (or "-" "+")) 302 ;; (or (: (+ digit) (? "." (* digit))) 303 ;; (: "." (+ digit))) 304 ;; (? "e" (? (or "-" "+")) (+ digit))) 305 ;; eos) 306 "\\`rgbi:[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)/[[:space:]]*\\([+-]?\\(?:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\|\\.[[:digit:]]+\\)\\(?:e[+-]?[[:digit:]]+\\)?\\)\\'" 307 spec) 308 (let ((r (round (* (string-to-number (match-string 1 spec)) 65535))) 309 (g (round (* (string-to-number (match-string 2 spec)) 65535))) 310 (b (round (* (string-to-number (match-string 3 spec)) 65535)))) 311 (when (and (<= 0 r) (<= r 65535) 312 (<= 0 g) (<= g 65535) 313 (<= 0 b) (<= b 65535)) 314 (list r g b)))))))) 315 316 ;;;; Defined in subr.el 317 318 ;;* INCOMPLETE FEATURE: Should handle multibyte regular expressions 319 (compat-defun string-replace (fromstring tostring instring) 320 "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs." 321 (when (equal fromstring "") 322 (signal 'wrong-length-argument '(0))) 323 (let ((case-fold-search nil)) 324 (replace-regexp-in-string 325 (regexp-quote fromstring) 326 tostring instring 327 t t))) 328 329 (compat-defun always (&rest _arguments) 330 "Do nothing and return t. 331 This function accepts any number of ARGUMENTS, but ignores them. 332 Also see `ignore'." 333 t) 334 335 ;;* UNTESTED 336 (compat-defun insert-into-buffer (buffer &optional start end) 337 "Insert the contents of the current buffer into BUFFER. 338 If START/END, only insert that region from the current buffer. 339 Point in BUFFER will be placed after the inserted text." 340 (let ((current (current-buffer))) 341 (with-current-buffer buffer 342 (insert-buffer-substring current start end)))) 343 344 ;;* UNTESTED 345 (compat-defun replace-string-in-region (string replacement &optional start end) 346 "Replace STRING with REPLACEMENT in the region from START to END. 347 The number of replaced occurrences are returned, or nil if STRING 348 doesn't exist in the region. 349 350 If START is nil, use the current point. If END is nil, use `point-max'. 351 352 Comparisons and replacements are done with fixed case." 353 (if start 354 (when (< start (point-min)) 355 (error "Start before start of buffer")) 356 (setq start (point))) 357 (if end 358 (when (> end (point-max)) 359 (error "End after end of buffer")) 360 (setq end (point-max))) 361 (save-excursion 362 (let ((matches 0) 363 (case-fold-search nil)) 364 (goto-char start) 365 (while (search-forward string end t) 366 (delete-region (match-beginning 0) (match-end 0)) 367 (insert replacement) 368 (setq matches (1+ matches))) 369 (and (not (zerop matches)) 370 matches)))) 371 372 ;;* UNTESTED 373 (compat-defun replace-regexp-in-region (regexp replacement &optional start end) 374 "Replace REGEXP with REPLACEMENT in the region from START to END. 375 The number of replaced occurrences are returned, or nil if REGEXP 376 doesn't exist in the region. 377 378 If START is nil, use the current point. If END is nil, use `point-max'. 379 380 Comparisons and replacements are done with fixed case. 381 382 REPLACEMENT can use the following special elements: 383 384 `\\&' in NEWTEXT means substitute original matched text. 385 `\\N' means substitute what matched the Nth `\\(...\\)'. 386 If Nth parens didn't match, substitute nothing. 387 `\\\\' means insert one `\\'. 388 `\\?' is treated literally." 389 (if start 390 (when (< start (point-min)) 391 (error "Start before start of buffer")) 392 (setq start (point))) 393 (if end 394 (when (> end (point-max)) 395 (error "End after end of buffer")) 396 (setq end (point-max))) 397 (save-excursion 398 (let ((matches 0) 399 (case-fold-search nil)) 400 (goto-char start) 401 (while (re-search-forward regexp end t) 402 (replace-match replacement t) 403 (setq matches (1+ matches))) 404 (and (not (zerop matches)) 405 matches)))) 406 407 ;;* UNTESTED 408 (compat-defun buffer-local-boundp (symbol buffer) 409 "Return non-nil if SYMBOL is bound in BUFFER. 410 Also see `local-variable-p'." 411 (catch 'fail 412 (condition-case nil 413 (buffer-local-value symbol buffer) 414 (void-variable nil (throw 'fail nil))) 415 t)) 416 417 ;;* UNTESTED 418 (compat-defmacro with-existing-directory (&rest body) 419 "Execute BODY with `default-directory' bound to an existing directory. 420 If `default-directory' is already an existing directory, it's not changed." 421 (declare (indent 0) (debug t)) 422 (let ((quit (make-symbol "with-existing-directory-quit"))) 423 `(catch ',quit 424 (dolist (dir (list default-directory 425 (expand-file-name "~/") 426 (getenv "TMPDIR") 427 "/tmp/" 428 ;; XXX: check if "/" works on non-POSIX 429 ;; system. 430 "/")) 431 (when (and dir (file-exists-p dir)) 432 (throw ',quit (let ((default-directory dir)) 433 ,@body))))))) 434 435 ;;* UNTESTED 436 (compat-defmacro dlet (binders &rest body) 437 "Like `let' but using dynamic scoping." 438 (declare (indent 1) (debug let)) 439 `(let (_) 440 ,@(mapcar (lambda (binder) 441 `(defvar ,(if (consp binder) (car binder) binder))) 442 binders) 443 (let ,binders ,@body))) 444 445 (compat-defun ensure-list (object) 446 "Return OBJECT as a list. 447 If OBJECT is already a list, return OBJECT itself. If it's 448 not a list, return a one-element list containing OBJECT." 449 (if (listp object) 450 object 451 (list object))) 452 453 (compat-defun subr-primitive-p (object) 454 "Return t if OBJECT is a built-in primitive function." 455 (subrp object)) 456 457 ;;;; Defined in subr-x.el 458 459 (compat-defun string-clean-whitespace (string) 460 "Clean up whitespace in STRING. 461 All sequences of whitespaces in STRING are collapsed into a 462 single space character, and leading/trailing whitespace is 463 removed." 464 :feature 'subr-x 465 (let ((blank "[[:blank:]\r\n]+")) 466 (replace-regexp-in-string 467 "^[[:blank:]\r\n]+\\|[[:blank:]\r\n]+$" 468 "" 469 (replace-regexp-in-string 470 blank " " string)))) 471 472 (compat-defun string-fill (string length) 473 "Clean up whitespace in STRING. 474 All sequences of whitespaces in STRING are collapsed into a 475 single space character, and leading/trailing whitespace is 476 removed." 477 :feature 'subr-x 478 (with-temp-buffer 479 (insert string) 480 (goto-char (point-min)) 481 (let ((fill-column length) 482 (adaptive-fill-mode nil)) 483 (fill-region (point-min) (point-max))) 484 (buffer-string))) 485 486 (compat-defun string-lines (string &optional omit-nulls) 487 "Split STRING into a list of lines. 488 If OMIT-NULLS, empty lines will be removed from the results." 489 :feature 'subr-x 490 (split-string string "\n" omit-nulls)) 491 492 (compat-defun string-pad (string length &optional padding start) 493 "Pad STRING to LENGTH using PADDING. 494 If PADDING is nil, the space character is used. If not nil, it 495 should be a character. 496 497 If STRING is longer than the absolute value of LENGTH, no padding 498 is done. 499 500 If START is nil (or not present), the padding is done to the end 501 of the string, and if non-nil, padding is done to the start of 502 the string." 503 :feature 'subr-x 504 (unless (natnump length) 505 (signal 'wrong-type-argument (list 'natnump length))) 506 (let ((pad-length (- length (length string)))) 507 (if (< pad-length 0) 508 string 509 (concat (and start 510 (make-string pad-length (or padding ?\s))) 511 string 512 (and (not start) 513 (make-string pad-length (or padding ?\s))))))) 514 515 (compat-defun string-chop-newline (string) 516 "Remove the final newline (if any) from STRING." 517 :feature 'subr-x 518 (if (and (>= (length string) 1) (= (aref string (1- (length string))) ?\n)) 519 (substring string 0 -1) 520 string)) 521 522 (compat-defmacro named-let (name bindings &rest body) 523 "Looping construct taken from Scheme. 524 Like `let', bind variables in BINDINGS and then evaluate BODY, 525 but with the twist that BODY can evaluate itself recursively by 526 calling NAME, where the arguments passed to NAME are used 527 as the new values of the bound variables in the recursive invocation." 528 :feature 'subr-x 529 (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) 530 (let ((fargs (mapcar (lambda (b) 531 (let ((var (if (consp b) (car b) b))) 532 (make-symbol (symbol-name var)))) 533 bindings)) 534 (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)) 535 rargs) 536 (dotimes (i (length bindings)) 537 (let ((b (nth i bindings))) 538 (push (list (if (consp b) (car b) b) (nth i fargs)) 539 rargs) 540 (setf (if (consp b) (car b) b) 541 (nth i fargs)))) 542 (letrec 543 ((quit (make-symbol "quit")) (self (make-symbol "self")) 544 (total-tco t) 545 (macro (lambda (&rest args) 546 (setq total-tco nil) 547 `(funcall ,self . ,args))) 548 ;; Based on `cl--self-tco': 549 (tco-progn (lambda (exprs) 550 (append 551 (butlast exprs) 552 (list (funcall tco (car (last exprs))))))) 553 (tco (lambda (expr) 554 (cond 555 ((eq (car-safe expr) 'if) 556 (append (list 'if 557 (cadr expr) 558 (funcall tco (nth 2 expr))) 559 (funcall tco-progn (nthcdr 3 expr)))) 560 ((eq (car-safe expr) 'cond) 561 (let ((conds (cdr expr)) body) 562 (while conds 563 (let ((branch (pop conds))) 564 (push (cond 565 ((cdr branch) ;has tail 566 (funcall tco-progn branch)) 567 ((null conds) ;last element 568 (list t (funcall tco (car branch)))) 569 ((progn 570 branch))) 571 body))) 572 (cons 'cond (nreverse body)))) 573 ((eq (car-safe expr) 'or) 574 (if (cddr expr) 575 (let ((var (make-symbol "var"))) 576 `(let ((,var ,(cadr expr))) 577 (if ,var ,(funcall tco var) 578 ,(funcall tco (cons 'or (cddr expr)))))) 579 (funcall tco (cadr expr)))) 580 ((eq (car-safe expr) 'condition-case) 581 (append (list 'condition-case (cadr expr) (nth 2 expr)) 582 (mapcar 583 (lambda (handler) 584 (cons (car handler) 585 (funcall tco-progn (cdr handler)))) 586 (nthcdr 3 expr)))) 587 ((memq (car-safe expr) '(and progn)) 588 (cons (car expr) (funcall tco-progn (cdr expr)))) 589 ((memq (car-safe expr) '(let let*)) 590 (append (list (car expr) (cadr expr)) 591 (funcall tco-progn (cddr expr)))) 592 ((eq (car-safe expr) name) 593 (let (sets (args (cdr expr))) 594 (dolist (farg fargs) 595 (push (list farg (pop args)) 596 sets)) 597 (cons 'setq (apply #'nconc (nreverse sets))))) 598 (`(throw ',quit ,expr)))))) 599 (let ((tco-body (funcall tco (macroexpand-all (macroexp-progn body))))) 600 (when tco-body 601 (setq body `((catch ',quit 602 (while t (let ,rargs ,@(macroexp-unprogn tco-body)))))))) 603 (let ((expand (macroexpand-all (macroexp-progn body) (list (cons name macro))))) 604 (if total-tco 605 `(let ,bindings ,expand) 606 `(funcall 607 (letrec ((,self (lambda ,fargs ,expand))) ,self) 608 ,@aargs)))))) 609 610 ;;;; Defined in files.el 611 612 (declare-function compat--string-trim-left "compat-26" (string &optional regexp)) 613 (declare-function compat--directory-name-p "compat-25" (name)) 614 (compat-defun file-name-with-extension (filename extension) 615 "Set the EXTENSION of a FILENAME. 616 The extension (in a file name) is the part that begins with the last \".\". 617 618 Trims a leading dot from the EXTENSION so that either \"foo\" or 619 \".foo\" can be given. 620 621 Errors if the FILENAME or EXTENSION are empty, or if the given 622 FILENAME has the format of a directory. 623 624 See also `file-name-sans-extension'." 625 (let ((extn (compat--string-trim-left extension "[.]"))) 626 (cond 627 ((string= filename "") 628 (error "Empty filename")) 629 ((string= extn "") 630 (error "Malformed extension: %s" extension)) 631 ((compat--directory-name-p filename) 632 (error "Filename is a directory: %s" filename)) 633 (t 634 (concat (file-name-sans-extension filename) "." extn))))) 635 636 ;;* UNTESTED 637 (compat-defun directory-empty-p (dir) 638 "Return t if DIR names an existing directory containing no other files. 639 Return nil if DIR does not name a directory, or if there was 640 trouble determining whether DIR is a directory or empty. 641 642 Symbolic links to directories count as directories. 643 See `file-symlink-p' to distinguish symlinks." 644 (and (file-directory-p dir) 645 (null (directory-files dir nil directory-files-no-dot-files-regexp t)))) 646 647 (compat-defun file-modes-number-to-symbolic (mode &optional filetype) 648 "Return a string describing a file's MODE. 649 For instance, if MODE is #o700, then it produces `-rwx------'. 650 FILETYPE if provided should be a character denoting the type of file, 651 such as `?d' for a directory, or `?l' for a symbolic link and will override 652 the leading `-' char." 653 (string 654 (or filetype 655 (pcase (lsh mode -12) 656 ;; POSIX specifies that the file type is included in st_mode 657 ;; and provides names for the file types but values only for 658 ;; the permissions (e.g., S_IWOTH=2). 659 660 ;; (#o017 ??) ;; #define S_IFMT 00170000 661 (#o014 ?s) ;; #define S_IFSOCK 0140000 662 (#o012 ?l) ;; #define S_IFLNK 0120000 663 ;; (8 ??) ;; #define S_IFREG 0100000 664 (#o006 ?b) ;; #define S_IFBLK 0060000 665 (#o004 ?d) ;; #define S_IFDIR 0040000 666 (#o002 ?c) ;; #define S_IFCHR 0020000 667 (#o001 ?p) ;; #define S_IFIFO 0010000 668 (_ ?-))) 669 (if (zerop (logand 256 mode)) ?- ?r) 670 (if (zerop (logand 128 mode)) ?- ?w) 671 (if (zerop (logand 64 mode)) 672 (if (zerop (logand 2048 mode)) ?- ?S) 673 (if (zerop (logand 2048 mode)) ?x ?s)) 674 (if (zerop (logand 32 mode)) ?- ?r) 675 (if (zerop (logand 16 mode)) ?- ?w) 676 (if (zerop (logand 8 mode)) 677 (if (zerop (logand 1024 mode)) ?- ?S) 678 (if (zerop (logand 1024 mode)) ?x ?s)) 679 (if (zerop (logand 4 mode)) ?- ?r) 680 (if (zerop (logand 2 mode)) ?- ?w) 681 (if (zerop (logand 512 mode)) 682 (if (zerop (logand 1 mode)) ?- ?x) 683 (if (zerop (logand 1 mode)) ?T ?t)))) 684 685 ;;* UNTESTED 686 (compat-defun file-backup-file-names (filename) 687 "Return a list of backup files for FILENAME. 688 The list will be sorted by modification time so that the most 689 recent files are first." 690 ;; `make-backup-file-name' will get us the right directory for 691 ;; ordinary or numeric backups. It might create a directory for 692 ;; backups as a side-effect, according to `backup-directory-alist'. 693 (let* ((filename (file-name-sans-versions 694 (make-backup-file-name (expand-file-name filename)))) 695 (dir (file-name-directory filename)) 696 files) 697 (dolist (file (file-name-all-completions 698 (file-name-nondirectory filename) dir)) 699 (let ((candidate (concat dir file))) 700 (when (and (backup-file-name-p candidate) 701 (string= (file-name-sans-versions candidate) filename)) 702 (push candidate files)))) 703 (sort files #'file-newer-than-file-p))) 704 705 (compat-defun make-lock-file-name (filename) 706 "Make a lock file name for FILENAME. 707 This prepends \".#\" to the non-directory part of FILENAME, and 708 doesn't respect `lock-file-name-transforms', as Emacs 28.1 and 709 onwards does." 710 (expand-file-name 711 (concat 712 ".#" (file-name-nondirectory filename)) 713 (file-name-directory filename))) 714 715 ;;;; Defined in files-x.el 716 717 (declare-function tramp-tramp-file-p "tramp" (name)) 718 719 ;;* UNTESTED 720 (compat-defun null-device () 721 "Return the best guess for the null device." 722 (require 'tramp) 723 (if (tramp-tramp-file-p default-directory) 724 "/dev/null" 725 null-device)) 726 727 ;;;; Defined in minibuffer.el 728 729 (compat-defun format-prompt (prompt default &rest format-args) 730 "Format PROMPT with DEFAULT. 731 If FORMAT-ARGS is nil, PROMPT is used as a plain string. If 732 FORMAT-ARGS is non-nil, PROMPT is used as a format control 733 string, and FORMAT-ARGS are the arguments to be substituted into 734 it. See `format' for details. 735 736 If DEFAULT is a list, the first element is used as the default. 737 If not, the element is used as is. 738 739 If DEFAULT is nil or an empty string, no \"default value\" string 740 is included in the return value." 741 (concat 742 (if (null format-args) 743 prompt 744 (apply #'format prompt format-args)) 745 (and default 746 (or (not (stringp default)) 747 (> (length default) 0)) 748 (format " (default %s)" 749 (if (consp default) 750 (car default) 751 default))) 752 ": ")) 753 754 ;;;; Defined in windows.el 755 756 ;;* UNTESTED 757 (compat-defun count-windows (&optional minibuf all-frames) 758 "Handle optional argument ALL-FRAMES: 759 760 If ALL-FRAMES is non-nil, count the windows in all frames instead 761 just the selected frame." 762 :prefix t 763 (if all-frames 764 (let ((sum 0)) 765 (dolist (frame (frame-list)) 766 (with-selected-frame frame 767 (setq sum (+ (count-windows minibuf) sum)))) 768 sum) 769 (count-windows minibuf))) 770 771 ;;;; Defined in thingatpt.el 772 773 (declare-function mouse-set-point "mouse" (event &optional promote-to-region)) 774 775 ;;* UNTESTED 776 (compat-defun thing-at-mouse (event thing &optional no-properties) 777 "Return the THING at mouse click. 778 Like `thing-at-point', but tries to use the event 779 where the mouse button is clicked to find a thing nearby." 780 :feature 'thingatpt 781 (save-excursion 782 (mouse-set-point event) 783 (thing-at-point thing no-properties))) 784 785 ;;;; Defined in macroexp.el 786 787 ;;* UNTESTED 788 (compat-defun macroexp-file-name () 789 "Return the name of the file from which the code comes. 790 Returns nil when we do not know. 791 A non-nil result is expected to be reliable when called from a macro in order 792 to find the file in which the macro's call was found, and it should be 793 reliable as well when used at the top-level of a file. 794 Other uses risk returning non-nil value that point to the wrong file." 795 :feature 'macroexp 796 (let ((file (car (last current-load-list)))) 797 (or (if (stringp file) file) 798 (bound-and-true-p byte-compile-current-file)))) 799 800 ;;;; Defined in env.el 801 802 ;;* UNTESTED 803 (compat-defmacro with-environment-variables (variables &rest body) 804 "Set VARIABLES in the environent and execute BODY. 805 VARIABLES is a list of variable settings of the form (VAR VALUE), 806 where VAR is the name of the variable (a string) and VALUE 807 is its value (also a string). 808 809 The previous values will be be restored upon exit." 810 (declare (indent 1) (debug (sexp body))) 811 (unless (consp variables) 812 (error "Invalid VARIABLES: %s" variables)) 813 `(let ((process-environment (copy-sequence process-environment))) 814 ,@(mapcar (lambda (elem) 815 `(setenv ,(car elem) ,(cadr elem))) 816 variables) 817 ,@body)) 818 819 ;;;; Defined in button.el 820 821 ;;* UNTESTED 822 (compat-defun button-buttonize (string callback &optional data) 823 "Make STRING into a button and return it. 824 When clicked, CALLBACK will be called with the DATA as the 825 function argument. If DATA isn't present (or is nil), the button 826 itself will be used instead as the function argument." 827 :feature 'button 828 (propertize string 829 'face 'button 830 'button t 831 'follow-link t 832 'category t 833 'button-data data 834 'keymap button-map 835 'action callback)) 836 837 ;;;; Defined in autoload.el 838 839 (defvar generated-autoload-file) 840 841 ;;* UNTESTED 842 (compat-defun make-directory-autoloads (dir output-file) 843 "Update autoload definitions for Lisp files in the directories DIRS. 844 DIR can be either a single directory or a list of 845 directories. (The latter usage is discouraged.) 846 847 The autoloads will be written to OUTPUT-FILE. If any Lisp file 848 binds `generated-autoload-file' as a file-local variable, write 849 its autoloads into the specified file instead. 850 851 The function does NOT recursively descend into subdirectories of the 852 directory or directories specified." 853 (let ((generated-autoload-file output-file)) 854 ;; We intentionally don't sharp-quote 855 ;; `update-directory-autoloads', because it was deprecated in 856 ;; Emacs 28 and we don't want to trigger the byte compiler for 857 ;; newer versions. 858 (apply 'update-directory-autoloads 859 (if (listp dir) dir (list dir))))) 860 861 ;;;; Defined in time-data.el 862 863 (compat-defun decoded-time-period (time) 864 "Interpret DECODED as a period and return its length in seconds. 865 For computational purposes, years are 365 days long and months 866 are 30 days long." 867 :feature 'time-date 868 :version "28" 869 ;; Inlining the definitions from compat-27 870 (+ (if (consp (nth 0 time)) 871 ;; Fractional second. 872 (/ (float (car (nth 0 time))) 873 (cdr (nth 0 time))) 874 (or (nth 0 time) 0)) 875 (* (or (nth 1 time) 0) 60) 876 (* (or (nth 2 time) 0) 60 60) 877 (* (or (nth 3 time) 0) 60 60 24) 878 (* (or (nth 4 time) 0) 60 60 24 30) 879 (* (or (nth 5 time) 0) 60 60 24 365))) 880 881 (compat--inhibit-prefixed (provide 'compat-28)) 882 ;;; compat-28.el ends here