compat-macs.el (13409B)
1 ;;; compat-macs.el --- Compatibility Macros -*- lexical-binding: t; no-byte-compile: t; -*- 2 3 ;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. 4 5 ;; Author: Philip Kaludercic <philipk@posteo.net> 6 ;; Keywords: lisp 7 8 ;; This program is free software; you can redistribute it and/or modify 9 ;; it under the terms of the GNU General Public License as published by 10 ;; the Free Software Foundation, either version 3 of the License, or 11 ;; (at your option) any later version. 12 13 ;; This program is distributed in the hope that it will be useful, 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; GNU General Public License for more details. 17 18 ;; You should have received a copy of the GNU General Public License 19 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 20 21 ;;; Commentary: 22 23 ;; These macros are used to define compatibility functions, macros and 24 ;; advice. 25 26 ;;; Code: 27 28 (defmacro compat--ignore (&rest _) 29 "Ignore all arguments." 30 nil) 31 32 (defvar compat--inhibit-prefixed nil 33 "Non-nil means that prefixed definitions are not loaded. 34 A prefixed function is something like `compat-assoc', that is 35 only made visible when the respective compatibility version file 36 is loaded (in this case `compat-26').") 37 38 (defmacro compat--inhibit-prefixed (&rest body) 39 "Ignore BODY unless `compat--inhibit-prefixed' is true." 40 `(unless (bound-and-true-p compat--inhibit-prefixed) 41 ,@body)) 42 43 (defvar compat-current-version nil 44 "Default version to use when no explicit version was given.") 45 46 (defmacro compat-declare-version (version) 47 "Set the Emacs version that is currently being handled to VERSION." 48 ;; FIXME: Avoid setting the version for any definition that might 49 ;; follow, but try to restrict it to the current file/buffer. 50 (setq compat-current-version version) 51 nil) 52 53 (defvar compat--generate-function #'compat--generate-default 54 "Function used to generate compatibility code. 55 The function must take six arguments: NAME, DEF-FN, INSTALL-FN, 56 CHECK-FN, ATTR and TYPE. The resulting body is constructed by 57 invoking the functions DEF-FN (passed the \"realname\" and the 58 version number, returning the compatibility definition), the 59 INSTALL-FN (passed the \"realname\" and returning the 60 installation code), CHECK-FN (passed the \"realname\" and 61 returning a check to see if the compatibility definition should 62 be installed). ATTR is a plist used to modify the generated 63 code. The following attributes are handled, all others are 64 ignored: 65 66 - :min-version :: Prevent the compatibility definition from begin 67 installed in versions older than indicated (string). 68 69 - :max-version :: Prevent the compatibility definition from begin 70 installed in versions newer than indicated (string). 71 72 - :feature :: The library the code is supposed to be loaded 73 with (via `eval-after-load'). 74 75 - :cond :: Only install the compatibility code, iff the value 76 evaluates to non-nil. 77 78 For prefixed functions, this can be interpreted as a test to 79 `defalias' an existing definition or not. 80 81 - :no-highlight :: Do not highlight this definition as 82 compatibility function. 83 84 - :version :: Manual specification of the version the compatee 85 code was defined in (string). 86 87 - :realname :: Manual specification of a \"realname\" to use for 88 the compatibility definition (symbol). 89 90 - :notes :: Additional notes that a developer using this 91 compatibility function should keep in mind. 92 93 - :prefix :: Add a `compat-' prefix to the name, and define the 94 compatibility code unconditionally. 95 96 TYPE is used to set the symbol property `compat-type' for NAME.") 97 98 (defun compat--generate-default (name def-fn install-fn check-fn attr type) 99 "Generate a leaner compatibility definition. 100 See `compat-generate-function' for details on the arguments NAME, 101 DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE." 102 (let* ((min-version (plist-get attr :min-version)) 103 (max-version (plist-get attr :max-version)) 104 (feature (plist-get attr :feature)) 105 (cond (plist-get attr :cond)) 106 (version (or (plist-get attr :version) 107 compat-current-version)) 108 (realname (or (plist-get attr :realname) 109 (intern (format "compat--%S" name)))) 110 (check (cond 111 ((or (and min-version 112 (version< emacs-version min-version)) 113 (and max-version 114 (version< max-version emacs-version))) 115 '(compat--ignore)) 116 ((plist-get attr :prefix) 117 '(compat--inhibit-prefixed)) 118 ((and version (version<= version emacs-version) (not cond)) 119 '(compat--ignore)) 120 (`(when (and ,(if cond cond t) 121 ,(funcall check-fn))))))) 122 (cond 123 ((and (plist-get attr :prefix) (memq type '(func macro)) 124 (string-match "\\`compat-\\(.+\\)\\'" (symbol-name name)) 125 (let* ((actual-name (intern (match-string 1 (symbol-name name)))) 126 (body (funcall install-fn actual-name version))) 127 (when (and (version<= version emacs-version) 128 (fboundp actual-name)) 129 `(,@check 130 ,(if feature 131 ;; See https://nullprogram.com/blog/2018/02/22/: 132 `(eval-after-load ,feature `(funcall ',(lambda () ,body))) 133 body)))))) 134 ((plist-get attr :realname) 135 `(progn 136 ,(funcall def-fn realname version) 137 (,@check 138 ,(let ((body (funcall install-fn realname version))) 139 (if feature 140 ;; See https://nullprogram.com/blog/2018/02/22/: 141 `(eval-after-load ,feature `(funcall ',(lambda () ,body))) 142 body))))) 143 ((let* ((body (if (eq type 'advice) 144 `(,@check 145 ,(funcall def-fn realname version) 146 ,(funcall install-fn realname version)) 147 `(,@check ,(funcall def-fn name version))))) 148 (if feature 149 ;; See https://nullprogram.com/blog/2018/02/22/: 150 `(eval-after-load ,feature `(funcall ',(lambda () ,body))) 151 body)))))) 152 153 (defun compat-generate-common (name def-fn install-fn check-fn attr type) 154 "Common code for generating compatibility definitions. 155 See `compat-generate-function' for details on the arguments NAME, 156 DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE." 157 (when (and (plist-get attr :cond) (plist-get attr :prefix)) 158 (error "A prefixed function %s cannot have a condition" name)) 159 (funcall compat--generate-function 160 name def-fn install-fn check-fn attr type)) 161 162 (defun compat-common-fdefine (type name arglist docstring rest) 163 "Generate compatibility code for a function NAME. 164 TYPE is one of `func', for functions and `macro' for macros, and 165 `advice' ARGLIST is passed on directly to the definition, and 166 DOCSTRING is prepended with a compatibility note. REST contains 167 the remaining definition, that may begin with a property list of 168 attributes (see `compat-generate-common')." 169 (let ((oldname name) (body rest)) 170 (while (keywordp (car body)) 171 (setq body (cddr body))) 172 ;; It might be possible to set these properties otherwise. That 173 ;; should be looked into and implemented if it is the case. 174 (when (and (listp (car-safe body)) (eq (caar body) 'declare)) 175 (when (version<= emacs-version "25") 176 (delq (assq 'side-effect-free (car body)) (car body)) 177 (delq (assq 'pure (car body)) (car body)))) 178 ;; Check if we want an explicitly prefixed function 179 (when (plist-get rest :prefix) 180 (setq name (intern (format "compat-%s" name)))) 181 (compat-generate-common 182 name 183 (lambda (realname version) 184 `(,(cond 185 ((memq type '(func advice)) 'defun) 186 ((eq type 'macro) 'defmacro) 187 ((error "Unknown type"))) 188 ,realname ,arglist 189 ;; Prepend compatibility notice to the actual 190 ;; documentation string. 191 ,(let ((type (cond 192 ((eq type 'func) "function") 193 ((eq type 'macro) "macro") 194 ((eq type 'advice) "advice") 195 ((error "Unknown type"))))) 196 (if version 197 (format 198 "[Compatibility %s for `%S', defined in Emacs %s]\n\n%s" 199 type oldname version docstring) 200 (format 201 "[Compatibility %s for `%S']\n\n%s" 202 type oldname docstring))) 203 ;; Advice may use the implicit variable `oldfun', but 204 ;; to avoid triggering the byte compiler, we make 205 ;; sure the argument is used at least once. 206 ,@(if (eq type 'advice) 207 (cons '(ignore oldfun) body) 208 body))) 209 (lambda (realname _version) 210 (cond 211 ((memq type '(func macro)) 212 ;; Functions and macros are installed by 213 ;; aliasing the name of the compatible 214 ;; function to the name of the compatibility 215 ;; function. 216 `(defalias ',name #',realname)) 217 ((eq type 'advice) 218 `(advice-add ',name :around #',realname)))) 219 (lambda () 220 (cond 221 ((memq type '(func macro)) 222 `(not (fboundp ',name))) 223 ((eq type 'advice) t))) 224 rest type))) 225 226 (defmacro compat-defun (name arglist docstring &rest rest) 227 "Define NAME with arguments ARGLIST as a compatibility function. 228 The function must be documented in DOCSTRING. REST may begin 229 with a plist, that is interpreted by the macro but not passed on 230 to the actual function. See `compat-generate-common' for a 231 listing of attributes. 232 233 The definition will only be installed, if the version this 234 function was defined in, as indicated by the `:version' 235 attribute, is greater than the current Emacs version." 236 (declare (debug (&define name (&rest symbolp) 237 stringp 238 [&rest keywordp sexp] 239 def-body)) 240 (doc-string 3) (indent 2)) 241 (compat-common-fdefine 'func name arglist docstring rest)) 242 243 (defmacro compat-defmacro (name arglist docstring &rest rest) 244 "Define NAME with arguments ARGLIST as a compatibility macro. 245 The macro must be documented in DOCSTRING. REST may begin 246 with a plist, that is interpreted by this macro but not passed on 247 to the actual macro. See `compat-generate-common' for a 248 listing of attributes. 249 250 The definition will only be installed, if the version this 251 function was defined in, as indicated by the `:version' 252 attribute, is greater than the current Emacs version." 253 (declare (debug compat-defun) (doc-string 3) (indent 2)) 254 (compat-common-fdefine 'macro name arglist docstring rest)) 255 256 (defmacro compat-advise (name arglist docstring &rest rest) 257 "Define NAME with arguments ARGLIST as a compatibility advice. 258 The advice function must be documented in DOCSTRING. REST may 259 begin with a plist, that is interpreted by this macro but not 260 passed on to the actual advice function. See 261 `compat-generate-common' for a listing of attributes. The advice 262 wraps the old definition, that is accessible via using the symbol 263 `oldfun'. 264 265 The advice will only be installed, if the version this function 266 was defined in, as indicated by the `:version' attribute, is 267 greater than the current Emacs version." 268 (declare (debug compat-defun) (doc-string 3) (indent 2)) 269 (compat-common-fdefine 'advice name (cons 'oldfun arglist) docstring rest)) 270 271 (defmacro compat-defvar (name initval docstring &rest attr) 272 "Declare compatibility variable NAME with initial value INITVAL. 273 The obligatory documentation string DOCSTRING must be given. 274 275 The remaining arguments ATTR form a plist, modifying the 276 behaviour of this macro. See `compat-generate-common' for a 277 listing of attributes. Furthermore, `compat-defvar' also handles 278 the attribute `:local' that either makes the variable permanent 279 local with a value of `permanent' or just buffer local with any 280 non-nil value." 281 (declare (debug (name form stringp [&rest keywordp sexp])) 282 (doc-string 3) (indent 2)) 283 ;; Check if we want an explicitly prefixed function 284 (let ((oldname name)) 285 (when (plist-get attr :prefix) 286 (setq name (intern (format "compat-%s" name)))) 287 (compat-generate-common 288 name 289 (lambda (realname version) 290 (let ((localp (plist-get attr :local))) 291 `(progn 292 (,(if (plist-get attr :constant) 'defconst 'defvar) 293 ,realname ,initval 294 ;; Prepend compatibility notice to the actual 295 ;; documentation string. 296 ,(if version 297 (format 298 "[Compatibility variable for `%S', defined in Emacs %s]\n\n%s" 299 oldname version docstring) 300 (format 301 "[Compatibility variable for `%S']\n\n%s" 302 oldname docstring))) 303 ;; Make variable as local if necessary 304 ,(cond 305 ((eq localp 'permanent) 306 `(put ',realname 'permanent-local t)) 307 (localp 308 `(make-variable-buffer-local ',realname)))))) 309 (lambda (realname _version) 310 `(defvaralias ',name ',realname)) 311 (lambda () 312 `(not (boundp ',name))) 313 attr 'variable))) 314 315 (provide 'compat-macs) 316 ;;; compat-macs.el ends here