compat-30.el (15224B)
1 ;;; compat-30.el --- Functionality added in Emacs 30 -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2023-2024 Free Software Foundation, Inc. 4 5 ;; This program is free software; you can redistribute it and/or modify 6 ;; it under the terms of the GNU General Public License as published by 7 ;; the Free Software Foundation, either version 3 of the License, or 8 ;; (at your option) any later version. 9 10 ;; This program is distributed in the hope that it will be useful, 11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ;; GNU General Public License for more details. 14 15 ;; You should have received a copy of the GNU General Public License 16 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 17 18 ;;; Commentary: 19 20 ;; Functionality added in Emacs 30, needed by older Emacs versions. 21 22 ;;; Code: 23 24 (eval-when-compile (load "compat-macs.el" nil t t)) 25 (compat-require compat-29 "29.1") 26 27 ;; TODO Update to 30.1 as soon as the Emacs emacs-30 branch version bumped 28 (compat-version "30.0.50") 29 30 ;;;; Defined in lread.c 31 32 (compat-defun obarray-clear (ob) ;; <compat-tests:obarray> 33 "Remove all symbols from obarray OB." 34 (fillarray ob 0)) 35 36 ;;;; Defined in buffer.c 37 38 (compat-defun find-buffer (variable value) ;; <compat-tests:find-buffer> 39 "Return the buffer with buffer-local VARIABLE equal to VALUE. 40 If there is no such live buffer, return nil." 41 (cl-loop for buffer the buffers 42 if (equal (buffer-local-value variable buffer) value) 43 return buffer)) 44 45 (compat-defun get-truename-buffer (filename) ;; <compat-tests:get-truename-buffer> 46 "Return the buffer with `file-truename' equal to FILENAME (a string). 47 If there is no such live buffer, return nil. 48 See also `find-buffer-visiting'." 49 (find-buffer 'buffer-file-truename filename)) 50 51 ;;;; Defined in files.el 52 53 (compat-defun require-with-check (feature &optional filename noerror) ;; <compat-tests:require-with-check> 54 "If FEATURE is not already loaded, load it from FILENAME. 55 This is like `require' except if FEATURE is already a member of the list 56 `features’, then we check if this was provided by a different file than the 57 one that we would load now (presumably because `load-path' has been 58 changed since the file was loaded). 59 If it's the case, we either signal an error (the default), or forcibly reload 60 the new file (if NOERROR is equal to `reload'), or otherwise emit a warning." 61 (let ((lh load-history) 62 (res (require feature filename (if (eq noerror 'reload) nil noerror)))) 63 ;; If the `feature' was not yet provided, `require' just loaded the right 64 ;; file, so we're done. 65 (when (eq lh load-history) 66 ;; If `require' did nothing, we need to make sure that was warranted. 67 (let ((fn (locate-file (or filename (symbol-name feature)) 68 load-path (get-load-suffixes)))) 69 (cond 70 ((assoc fn load-history) nil) ;We loaded the right file. 71 ((eq noerror 'reload) (load fn nil 'nomessage)) 72 (t (funcall (if noerror #'warn #'error) 73 "Feature provided by other file: %S" feature))))) 74 res)) 75 76 ;;;; Defined in minibuffer.el 77 78 (compat-defun completion--metadata-get-1 (metadata prop) ;; <compat-tests:completion-metadata-get> 79 "Helper function. 80 See for `completion-metadata-get' for METADATA and PROP arguments." 81 (or (alist-get prop metadata) 82 (plist-get completion-extra-properties 83 (or (get prop 'completion-extra-properties--keyword) 84 (put prop 'completion-extra-properties--keyword 85 (intern (concat ":" (symbol-name prop)))))))) 86 87 (compat-defun completion-metadata-get (metadata prop) ;; <compat-tests:completion-metadata-get> 88 "Get property PROP from completion METADATA. 89 If the metadata specifies a completion category, the variables 90 `completion-category-overrides' and 91 `completion-category-defaults' take precedence for 92 category-specific overrides. If the completion metadata does not 93 specify the property, the `completion-extra-properties' plist is 94 consulted. Note that the keys of the 95 `completion-extra-properties' plist are keyword symbols, not 96 plain symbols." 97 :extended t 98 (if-let ((cat (and (not (eq prop 'category)) 99 (completion--metadata-get-1 metadata 'category))) 100 (over (completion--category-override cat prop))) 101 (cdr over) 102 (completion--metadata-get-1 metadata prop))) 103 104 (compat-defvar completion-lazy-hilit nil ;; <compat-tests:completion-lazy-hilit> 105 "If non-nil, request lazy highlighting of completion candidates. 106 107 Lisp programs (a.k.a. \"front ends\") that present completion 108 candidates may opt to bind this variable to a non-nil value when 109 calling functions (such as `completion-all-completions') which 110 produce completion candidates. This tells the underlying 111 completion styles that they do not need to fontify (i.e., 112 propertize with the `face' property) completion candidates in a 113 way that highlights the matching parts. Then it is the front end 114 which presents the candidates that becomes responsible for this 115 fontification. The front end does that by calling the function 116 `completion-lazy-hilit' on each completion candidate that is to be 117 displayed to the user. 118 119 Note that only some completion styles take advantage of this 120 variable for optimization purposes. Other styles will ignore the 121 hint and fontify eagerly as usual. It is still safe for a 122 front end to call `completion-lazy-hilit' in these situations. 123 124 To author a completion style that takes advantage of this variable, 125 see `completion-lazy-hilit-fn' and `completion-pcm--hilit-commonality'.") 126 127 (compat-defvar completion-lazy-hilit-fn nil ;; <compat-tests:completion-lazy-hilit> 128 "Fontification function set by lazy-highlighting completions styles. 129 When a given style wants to enable support for `completion-lazy-hilit' 130 \(which see), that style should set this variable to a function of one 131 argument. It will be called with each completion candidate, a string, to 132 be displayed to the user, and should destructively propertize these 133 strings with the `face' property.") 134 135 (compat-defun completion-lazy-hilit (str) ;; <compat-tests:completion-lazy-hilit> 136 "Return a copy of completion candidate STR that is `face'-propertized. 137 See documentation of the variable `completion-lazy-hilit' for more 138 details." 139 (if (and completion-lazy-hilit completion-lazy-hilit-fn) 140 (funcall completion-lazy-hilit-fn (copy-sequence str)) 141 str)) 142 143 ;;;; Defined in subr.el 144 145 (compat-defmacro static-if (condition then-form &rest else-forms) ;; <compat-tests:static-if> 146 "A conditional compilation macro. 147 Evaluate CONDITION at macro-expansion time. If it is non-nil, 148 expand the macro to THEN-FORM. Otherwise expand it to ELSE-FORMS 149 enclosed in a `progn' form. ELSE-FORMS may be empty." 150 (declare (indent 2) (debug (sexp sexp &rest sexp))) 151 (if (eval condition lexical-binding) 152 then-form 153 (cons 'progn else-forms))) 154 155 (compat-defun closurep (object) ;; <compat-tests:closurep> 156 "Return t if OBJECT is a function of type closure." 157 (declare (side-effect-free error-free)) 158 (eq (car-safe object) 'closure)) 159 160 (compat-defalias interpreted-function-p closurep) ;; <compat-tests:closurep> 161 162 (compat-defun primitive-function-p (object) ;; <compat-tests:primitive-function-p> 163 "Return t if OBJECT is a built-in primitive function. 164 This excludes special forms, since they are not functions." 165 (declare (side-effect-free error-free)) 166 (and (subrp object) 167 (not (or (with-no-warnings (subr-native-elisp-p object)) 168 (special-form-p object))))) 169 170 (compat-defalias drop nthcdr) ;; <compat-tests:drop> 171 172 (compat-defun merge-ordered-lists (lists &optional error-function) ;; <compat-tests:merge-ordered-lists> 173 "Merge LISTS in a consistent order. 174 LISTS is a list of lists of elements. 175 Merge them into a single list containing the same elements (removing 176 duplicates), obeying their relative positions in each list. 177 The order of the (sub)lists determines the final order in those cases where 178 the order within the sublists does not impose a unique choice. 179 Equality of elements is tested with `eql'. 180 181 If a consistent order does not exist, call ERROR-FUNCTION with 182 a remaining list of lists that we do not know how to merge. 183 It should return the candidate to use to continue the merge, which 184 has to be the head of one of the lists. 185 By default we choose the head of the first list." 186 (let ((result '())) 187 (setq lists (remq nil lists)) 188 (while (cdr (setq lists (delq nil lists))) 189 (let* ((next nil) 190 (tail lists)) 191 (while tail 192 (let ((candidate (caar tail)) 193 (other-lists lists)) 194 (while other-lists 195 (if (not (memql candidate (cdr (car other-lists)))) 196 (setq other-lists (cdr other-lists)) 197 (setq candidate nil) 198 (setq other-lists nil))) 199 (if (not candidate) 200 (setq tail (cdr tail)) 201 (setq next candidate) 202 (setq tail nil)))) 203 (unless next 204 (setq next (funcall (or error-function #'caar) lists)) 205 (unless (funcall 206 (eval-when-compile (if (fboundp 'compat--assoc) 'compat--assoc 'assoc)) 207 next lists #'eql) 208 (error "Invalid candidate returned by error-function: %S" next))) 209 (push next result) 210 (setq lists 211 (mapcar (lambda (l) (if (eql (car l) next) (cdr l) l)) 212 lists)))) 213 (if (null result) (car lists) 214 (append (nreverse result) (car lists))))) 215 216 (compat-defun copy-tree (tree &optional vectors-and-records) ;; <compat-tests:copy-tree> 217 "Handle copying records when optional arg is non-nil." 218 :extended t 219 (declare (side-effect-free error-free)) 220 (if (fboundp 'recordp) 221 (if (consp tree) 222 (let (result) 223 (while (consp tree) 224 (let ((newcar (car tree))) 225 (if (or (consp (car tree)) 226 (and vectors-and-records 227 (or (vectorp (car tree)) (recordp (car tree))))) 228 (setq newcar (compat--copy-tree (car tree) vectors-and-records))) 229 (push newcar result)) 230 (setq tree (cdr tree))) 231 (nconc (nreverse result) 232 (if (and vectors-and-records (or (vectorp tree) (recordp tree))) 233 (compat--copy-tree tree vectors-and-records) 234 tree))) 235 (if (and vectors-and-records (or (vectorp tree) (recordp tree))) 236 (let ((i (length (setq tree (copy-sequence tree))))) 237 (while (>= (setq i (1- i)) 0) 238 (aset tree i (compat--copy-tree (aref tree i) vectors-and-records))) 239 tree) 240 tree)) 241 (copy-tree tree vectors-and-records))) 242 243 ;;;; Defined in fns.c 244 245 (compat-defun value< (a b) ;; <compat-tests:value<> 246 "Return non-nil if A precedes B in standard value order. 247 A and B must have the same basic type. 248 Numbers are compared with <. 249 Strings and symbols are compared with string-lessp. 250 Lists, vectors, bool-vectors and records are compared lexicographically. 251 Markers are compared lexicographically by buffer and position. 252 Buffers and processes are compared by name. 253 Other types are considered unordered and the return value will be ‘nil’." 254 (cond 255 ((or (and (numberp a) (numberp b)) 256 (and (markerp a) (markerp b))) 257 (< a b)) 258 ((or (and (stringp a) (stringp b)) 259 (and (symbolp a) (symbolp b))) 260 (string< a b)) 261 ((and (listp a) (listp b)) 262 (while (and (consp a) (consp b) (equal (car a) (car b))) 263 (setq a (cdr a) b (cdr b))) 264 (cond 265 ((not b) nil) 266 ((not a) t) 267 ((and (consp a) (consp b)) (value< (car a) (car b))) 268 (t (value< a b)))) 269 ((and (vectorp a) (vectorp b)) 270 (let* ((na (length a)) 271 (nb (length b)) 272 (n (min na nb)) 273 (i 0)) 274 (while (and (< i n) (equal (aref a i) (aref b i))) 275 (cl-incf i)) 276 (if (< i n) (value< (aref a i) (aref b i)) (< n nb)))) 277 ((and (bufferp a) (bufferp b)) 278 ;; `buffer-name' is nil for killed buffers. 279 (setq a (buffer-name a) 280 b (buffer-name b)) 281 (cond 282 ((and a b) (string< a b)) 283 (b t))) 284 ((and (processp a) (processp b)) 285 (string< (process-name a) (process-name b))) 286 ;; TODO Add support for more types here. 287 ;; Other values of equal type are considered unordered (return value nil). 288 ((eq (type-of a) (type-of b)) nil) 289 ;; Different types. 290 (t (error "value< type mismatch: %S %S" a b)))) 291 292 (compat-defun sort (seq &optional lessp &rest rest) ;; <compat-tests:sort> 293 "Sort function with support for keyword arguments. 294 The following arguments are defined: 295 296 :key FUNC -- FUNC is a function that takes a single element from SEQ and 297 returns the key value to be used in comparison. If absent or nil, 298 `identity' is used. 299 300 :lessp FUNC -- FUNC is a function that takes two arguments and returns 301 non-nil if the first element should come before the second. 302 If absent or nil, `value<' is used. 303 304 :reverse BOOL -- if BOOL is non-nil, the sorting order implied by FUNC is 305 reversed. This does not affect stability: equal elements still retain 306 their order in the input sequence. 307 308 :in-place BOOL -- if BOOL is non-nil, SEQ is sorted in-place and returned. 309 Otherwise, a sorted copy of SEQ is returned and SEQ remains unmodified; 310 this is the default. 311 312 For compatibility, the calling convention (sort SEQ LESSP) can also be used; 313 in this case, sorting is always done in-place." 314 :extended t 315 (let ((in-place t) (reverse nil) (orig-seq seq)) 316 (when (or (not lessp) rest) 317 (setq 318 rest (if lessp (cons lessp rest) rest) 319 in-place (plist-get rest :in-place) 320 reverse (plist-get rest :reverse) 321 lessp (let ((key (plist-get rest :key)) 322 (< (or (plist-get rest :lessp) #'value<))) 323 (if key 324 (lambda (a b) (funcall < (funcall key a) (funcall key b))) 325 <)) 326 seq (if (or (and (eval-when-compile (< emacs-major-version 25)) (vectorp orig-seq)) 327 in-place) 328 seq 329 (copy-sequence seq)))) 330 ;; Emacs 24 does not support vectors. Convert to list. 331 (when (and (eval-when-compile (< emacs-major-version 25)) (vectorp orig-seq)) 332 (setq seq (append seq nil))) 333 (setq seq (if reverse 334 (nreverse (sort (nreverse seq) lessp)) 335 (sort seq lessp))) 336 ;; Emacs 24: Convert back to vector. 337 (if (and (eval-when-compile (< emacs-major-version 25)) (vectorp orig-seq)) 338 (if in-place 339 (cl-loop for i from 0 for x in seq 340 do (aset orig-seq i x) 341 finally return orig-seq) 342 (apply #'vector seq)) 343 seq))) 344 345 ;;;; Defined in mule-cmds.el 346 347 (compat-defun char-to-name (char) ;; <compat-tests:char-to-name> 348 "Return the Unicode name for CHAR, if it has one, else nil. 349 Return nil if CHAR is not a character." 350 (and (characterp char) 351 (or (get-char-code-property char 'name) 352 (get-char-code-property char 'old-name)))) 353 354 (provide 'compat-30) 355 ;;; compat-30.el ends here