emacs/code/elpa/compat-28.1.2.0/compat-macs.el

;;; compat-macs.el --- Compatibility Macros           -*- lexical-binding: t; -*-

;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.

;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords: lisp

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; These macros are used to define compatibility functions, macros and
;; advice.

;;; Code:

(defmacro compat--ignore (&rest _)
  "Ignore all arguments."
  nil)

(defvar compat--inhibit-prefixed nil
  "Non-nil means that prefixed definitions are not loaded.
A prefixed function is something like `compat-assoc', that is
only made visible when the respective compatibility version file
is loaded (in this case `compat-26').")

(defmacro compat--inhibit-prefixed (&rest body)
  "Ignore BODY unless `compat--inhibit-prefixed' is true."
  `(unless (bound-and-true-p compat--inhibit-prefixed)
     ,@body))

(defvar compat--generate-function #'compat--generate-minimal
  "Function used to generate compatibility code.
The function must take six arguments: NAME, DEF-FN, INSTALL-FN,
CHECK-FN, ATTR and TYPE.  The resulting body is constructed by
invoking the functions DEF-FN (passed the \"realname\" and the
version number, returning the compatibility definition), the
INSTALL-FN (passed the \"realname\" and returning the
installation code), CHECK-FN (passed the \"realname\" and
returning a check to see if the compatibility definition should
be installed).  ATTR is a plist used to modify the generated
code.  The following attributes are handled, all others are
ignored:

- :min-version :: Prevent the compatibility definition from begin
  installed in versions older than indicated (string).

- :max-version :: Prevent the compatibility definition from begin
  installed in versions newer than indicated (string).

- :feature :: The library the code is supposed to be loaded
  with (via `eval-after-load').

- :cond :: Only install the compatibility code, iff the value
  evaluates to non-nil.

  For prefixed functions, this can be interpreted as a test to
  `defalias' an existing definition or not.

- :no-highlight :: Do not highlight this definition as
  compatibility function.

- :version :: Manual specification of the version the compatee
  code was defined in (string).

- :realname :: Manual specification of a \"realname\" to use for
  the compatibility definition (symbol).

- :notes :: Additional notes that a developer using this
  compatibility function should keep in mind.

- :prefix :: Add a `compat-' prefix to the name, and define the
  compatibility code unconditionally.

TYPE is used to set the symbol property `compat-type' for NAME.")

(defun compat--generate-minimal (name def-fn install-fn check-fn attr type)
  "Generate a leaner compatibility definition.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
  (let* ((min-version (plist-get attr :min-version))
         (max-version (plist-get attr :max-version))
         (feature (plist-get attr :feature))
         (cond (plist-get attr :cond))
         (version ; If you edit this, also edit `compat--generate-verbose'.
          (or (plist-get attr :version)
              (let* ((file (car (last current-load-list)))
                     (file (if (stringp file)
                               ;; Some library, which requires compat-XY.el,
                               ;; is being compiled and compat-XY.el has not
                               ;; been compiled yet.
                               file
                             ;; compat-XY.el is being compiled.
                             (or (bound-and-true-p byte-compile-current-file)
                                 ;; Fallback to the buffer being evaluated.
                                 (buffer-file-name)))))
                (if (and file
                         (string-match
                          "compat-\\([[:digit:]]+\\)\\.\\(?:elc?\\)\\'" file))
                    (concat (match-string 1 file) ".1")
                  (error "BUG: No version number could be extracted")))))
         (realname (or (plist-get attr :realname)
                       (intern (format "compat--%S" name))))
         (check (cond
                 ((or (and min-version
                           (version< emacs-version min-version))
                      (and max-version
                           (version< max-version emacs-version)))
                  '(compat--ignore))
                 ((plist-get attr :prefix)
                  '(compat--inhibit-prefixed))
                 ((and version (version<= version emacs-version) (not cond))
                  '(compat--ignore))
                 (`(when (and ,(if cond cond t)
                              ,(funcall check-fn)))))))
    (cond
     ((and (plist-get attr :prefix) (memq type '(func macro))
           (string-match "\\`compat-\\(.+\\)\\'" (symbol-name name))
           (let* ((actual-name (intern (match-string 1 (symbol-name name))))
                  (body (funcall install-fn actual-name version)))
             (when (and (version<= version emacs-version)
                        (fboundp actual-name))
               `(,@check
                 ,(if feature
                      ;; See https://nullprogram.com/blog/2018/02/22/:
                      `(eval-after-load ,feature `(funcall ',(lambda () ,body)))
                    body))))))
     ((plist-get attr :realname)
      `(progn
         ,(funcall def-fn realname version)
         (,@check
          ,(let ((body (funcall install-fn realname version)))
             (if feature
                 ;; See https://nullprogram.com/blog/2018/02/22/:
                 `(eval-after-load ,feature `(funcall ',(lambda () ,body)))
               body)))))
     ((let* ((body (if (eq type 'advice)
                       `(,@check
                         ,(funcall def-fn realname version)
                         ,(funcall install-fn realname version))
                     `(,@check ,(funcall def-fn name version)))))
        (if feature
            ;; See https://nullprogram.com/blog/2018/02/22/:
            `(eval-after-load ,feature `(funcall ',(lambda () ,body)))
          body))))))

(defun compat--generate-verbose (name def-fn install-fn check-fn attr type)
  "Generate a more verbose compatibility definition, fit for testing.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
  (let* ((min-version (plist-get attr :min-version))
         (max-version (plist-get attr :max-version))
         (feature (plist-get attr :feature))
         (cond (plist-get attr :cond))
         (version ; If you edit this, also edit `compat--generate-minimal'.
          (or (plist-get attr :version)
              (let* ((file (car (last current-load-list)))
                     (file (if (stringp file)
                               file
                             (or (bound-and-true-p byte-compile-current-file)
                                 (buffer-file-name)))))
                (if (and file
                         (string-match
                          "compat-\\([[:digit:]]+\\)\\.\\(?:elc?\\)\\'" file))
                    (concat (match-string 1 file) ".1")
                  (error "BUG: No version number could be extracted")))))
         (realname (or (plist-get attr :realname)
                       (intern (format "compat--%S" name))))
         (body `(progn
                  (unless (or (null (get ',name 'compat-def))
                              (eq (get ',name 'compat-def) ',realname))
                    (error "Duplicate compatibility definition: %s (was %s, now %s)"
                           ',name (get ',name 'compat-def) ',realname))
                  (put ',name 'compat-def ',realname)
                  ,(funcall install-fn realname version))))
    `(progn
       (put ',realname 'compat-type ',type)
       (put ',realname 'compat-version ,version)
       (put ',realname 'compat-min-version ,min-version)
       (put ',realname 'compat-max-version ,max-version)
       (put ',realname 'compat-doc ,(plist-get attr :note))
       ,(funcall def-fn realname version)
       (,@(cond
           ((or (and min-version
                     (version< emacs-version min-version))
                (and max-version
                     (version< max-version emacs-version)))
            '(compat--ignore))
           ((plist-get attr :prefix)
            '(compat--inhibit-prefixed))
           ((and version (version<= version emacs-version) (not cond))
            '(compat--ignore))
           (`(when (and ,(if cond cond t)
                        ,(funcall check-fn)))))
        ,(if feature
             ;; See https://nullprogram.com/blog/2018/02/22/:
             `(eval-after-load ,feature `(funcall ',(lambda () ,body)))
           body)))))

(defun compat-generate-common (name def-fn install-fn check-fn attr type)
  "Common code for generating compatibility definitions.
See `compat-generate-function' for details on the arguments NAME,
DEF-FN, INSTALL-FN, CHECK-FN, ATTR and TYPE."
  (when (and (plist-get attr :cond) (plist-get attr :prefix))
    (error "A prefixed function %s cannot have a condition" name))
  (funcall compat--generate-function
           name def-fn install-fn check-fn attr type))

(defun compat-common-fdefine (type name arglist docstring rest)
  "Generate compatibility code for a function NAME.
TYPE is one of `func', for functions and `macro' for macros, and
`advice' ARGLIST is passed on directly to the definition, and
DOCSTRING is prepended with a compatibility note.  REST contains
the remaining definition, that may begin with a property list of
attributes (see `compat-generate-common')."
  (let ((oldname name) (body rest))
    (while (keywordp (car body))
      (setq body (cddr body)))
    ;; It might be possible to set these properties otherwise.  That
    ;; should be looked into and implemented if it is the case.
    (when (and (listp (car-safe body)) (eq (caar body) 'declare))
      (when (version<= emacs-version "25")
        (delq (assq 'side-effect-free (car body)) (car body))
        (delq (assq 'pure (car body)) (car body))))
    ;; Check if we want an explicitly prefixed function
    (when (plist-get rest :prefix)
      (setq name (intern (format "compat-%s" name))))
    (compat-generate-common
     name
     (lambda (realname version)
       `(,(cond
           ((memq type '(func advice)) 'defun)
           ((eq type 'macro) 'defmacro)
           ((error "Unknown type")))
         ,realname ,arglist
         ;; Prepend compatibility notice to the actual
         ;; documentation string.
         ,(let ((type (cond
                       ((eq type 'func) "function")
                       ((eq type 'macro) "macro")
                       ((eq type 'advice) "advice")
                       ((error "Unknown type")))))
            (if version
                (format
                 "[Compatibility %s for `%S', defined in Emacs %s]\n\n%s"
                 type oldname version docstring)
              (format
               "[Compatibility %s for `%S']\n\n%s"
               type oldname docstring)))
         ;; Advice may use the implicit variable `oldfun', but
         ;; to avoid triggering the byte compiler, we make
         ;; sure the argument is used at least once.
         ,@(if (eq type 'advice)
               (cons '(ignore oldfun) body)
             body)))
     (lambda (realname _version)
       (cond
        ((memq type '(func macro))
         ;; Functions and macros are installed by
         ;; aliasing the name of the compatible
         ;; function to the name of the compatibility
         ;; function.
         `(defalias ',name #',realname))
        ((eq type 'advice)
         `(advice-add ',name :around #',realname))))
     (lambda ()
       (cond
        ((memq type '(func macro))
         `(not (fboundp ',name)))
        ((eq type 'advice) t)))
     rest type)))

(defmacro compat-defun (name arglist docstring &rest rest)
  "Define NAME with arguments ARGLIST as a compatibility function.
The function must be documented in DOCSTRING.  REST may begin
with a plist, that is interpreted by the macro but not passed on
to the actual function.  See `compat-generate-common' for a
listing of attributes.

The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
  (declare (debug (&define name (&rest symbolp)
                           stringp
                           [&rest keywordp sexp]
                           def-body))
           (doc-string 3) (indent 2))
  (compat-common-fdefine 'func name arglist docstring rest))

(defmacro compat-defmacro (name arglist docstring &rest rest)
  "Define NAME with arguments ARGLIST as a compatibility macro.
The macro must be documented in DOCSTRING.  REST may begin
with a plist, that is interpreted by this macro but not passed on
to the actual macro.  See `compat-generate-common' for a
listing of attributes.

The definition will only be installed, if the version this
function was defined in, as indicated by the `:version'
attribute, is greater than the current Emacs version."
  (declare (debug compat-defun) (doc-string 3) (indent 2))
  (compat-common-fdefine 'macro name arglist docstring rest))

(defmacro compat-advise (name arglist docstring &rest rest)
  "Define NAME with arguments ARGLIST as a compatibility advice.
The advice function must be documented in DOCSTRING.  REST may
begin with a plist, that is interpreted by this macro but not
passed on to the actual advice function.  See
`compat-generate-common' for a listing of attributes.  The advice
wraps the old definition, that is accessible via using the symbol
`oldfun'.

The advice will only be installed, if the version this function
was defined in, as indicated by the `:version' attribute, is
greater than the current Emacs version."
  (declare (debug compat-defun) (doc-string 3) (indent 2))
  (compat-common-fdefine 'advice name (cons 'oldfun arglist) docstring rest))

(defmacro compat-defvar (name initval docstring &rest attr)
  "Declare compatibility variable NAME with initial value INITVAL.
The obligatory documentation string DOCSTRING must be given.

The remaining arguments ATTR form a plist, modifying the
behaviour of this macro.  See `compat-generate-common' for a
listing of attributes.  Furthermore, `compat-defvar' also handles
the attribute `:local' that either makes the variable permanent
local with a value of `permanent' or just buffer local with any
non-nil value."
  (declare (debug (name form stringp [&rest keywordp sexp]))
           (doc-string 3) (indent 2))
  ;; Check if we want an explicitly prefixed function
  (let ((oldname name))
    (when (plist-get attr :prefix)
      (setq name (intern (format "compat-%s" name))))
    (compat-generate-common
     name
     (lambda (realname version)
       (let ((localp (plist-get attr :local)))
         `(progn
            (,(if (plist-get attr :constant) 'defconst 'defvar)
             ,realname ,initval
             ;; Prepend compatibility notice to the actual
             ;; documentation string.
             ,(if version
                  (format
                   "[Compatibility variable for `%S', defined in Emacs %s]\n\n%s"
                   oldname version docstring)
                (format
                 "[Compatibility variable for `%S']\n\n%s"
                 oldname docstring)))
            ;; Make variable as local if necessary
            ,(cond
              ((eq localp 'permanent)
               `(put ',realname 'permanent-local t))
              (localp
               `(make-variable-buffer-local ',realname))))))
     (lambda (realname _version)
       `(defvaralias ',name ',realname))
     (lambda ()
       `(not (boundp ',name)))
     attr 'variable)))

(provide 'compat-macs)
;;; compat-macs.el ends here