code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/eieio-compat.el

   1 ;;; eieio-compat.el --- Compatibility with Older EIEIO versions  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: OO, lisp
   7 ;; Package: eieio
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Backward compatibility definition of old EIEIO functions in
  27 ;; terms of newer equivalent.
  28
  29 ;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are
  30 ;; now implemented on top of cl-generic.  The differences we have to
  31 ;; accommodate are:
  32 ;; - EIEIO's :static methods (turned into a new `eieio--static' specializer).
  33 ;; - EIEIO's support for `call-next-method' and `next-method-p' instead of
  34 ;;   `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming).
  35 ;; - Different errors are signaled.
  36 ;; - EIEIO's defgeneric does not reset the function.
  37 ;; - EIEIO's no-next-method and no-applicable-method can't be aliases of
  38 ;;   cl-generic's namesakes since they have different calling conventions,
  39 ;;   which means that packages that (defmethod no-next-method ..) don't work.
  40 ;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas
  41 ;;   cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically
  42 ;;   scoped.
  43
  44 ;;; Code:
  45
  46 (require 'eieio-core)
  47 (require 'cl-generic)
  48
  49 (put 'eieio--defalias 'byte-hunk-handler
  50      #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
  51 ;;;###autoload
  52 (defun eieio--defalias (name body)
  53   "Like `defalias', but with less side-effects.
  54 More specifically, it has no side-effects at all when the new function
  55 definition is the same (`eq') as the old one."
  56   (cl-assert (not (symbolp body)))
  57   (while (and (fboundp name) (symbolp (symbol-function name)))
  58     ;; Follow aliases, so methods applied to obsolete aliases still work.
  59     (setq name (symbol-function name)))
  60   (unless (and (fboundp name)
  61                (eq (symbol-function name) body))
  62     (defalias name body)))
  63
  64 ;;;###autoload
  65 (defmacro defgeneric (method args &optional doc-string)
  66   "Create a generic function METHOD.
  67 DOC-STRING is the base documentation for this class.  A generic
  68 function has no body, as its purpose is to decide which method body
  69 is appropriate to use.  Uses `defmethod' to create methods, and calls
  70 `defgeneric' for you.  With this implementation the ARGS are
  71 currently ignored.  You can use `defgeneric' to apply specialized
  72 top level documentation to a method."
  73   (declare (doc-string 3) (obsolete cl-defgeneric "25.1"))
  74   `(eieio--defalias ',method
  75                     (eieio--defgeneric-init-form
  76                      ',method
  77                      ,(if doc-string (help-add-fundoc-usage doc-string args)))))
  78
  79 ;;;###autoload
  80 (defmacro defmethod (method &rest args)
  81   "Create a new METHOD through `defgeneric' with ARGS.
  82
  83 The optional second argument KEY is a specifier that
  84 modifies how the method is called, including:
  85    :before  - Method will be called before the :primary
  86    :primary - The default if not specified
  87    :after   - Method will be called after the :primary
  88    :static  - First arg could be an object or class
  89 The next argument is the ARGLIST.  The ARGLIST specifies the arguments
  90 to the method as with `defun'.  The first argument can have a type
  91 specifier, such as:
  92   ((VARNAME CLASS) ARG2 ...)
  93 where VARNAME is the name of the local variable for the method being
  94 created.  The CLASS is a class symbol for a class made with `defclass'.
  95 A DOCSTRING comes after the ARGLIST, and is optional.
  96 All the rest of the args are the BODY of the method.  A method will
  97 return the value of the last form in the BODY.
  98
  99 Summary:
 100
 101  (defmethod mymethod [:before | :primary | :after | :static]
 102                      ((typearg class-name) arg2 &optional opt &rest rest)
 103     \"doc-string\"
 104      body)"
 105   (declare (doc-string 3) (obsolete cl-defmethod "25.1")
 106            (debug
 107             (&define                    ; this means we are defining something
 108              [&or name ("setf" :name setf name)]
 109              ;; ^^ This is the methods symbol
 110              [ &optional symbolp ]                ; this is key :before etc
 111              list                                 ; arguments
 112              [ &optional stringp ]                ; documentation string
 113              def-body                             ; part to be debugged
 114              )))
 115   (let* ((key (if (keywordp (car args)) (pop args)))
 116          (params (car args))
 117          (arg1 (car params))
 118          (fargs (if (consp arg1)
 119                    (cons (car arg1) (cdr params))
 120                  params))
 121          (class (if (consp arg1) (nth 1 arg1)))
 122          (code `(lambda ,fargs ,@(cdr args))))
 123     `(progn
 124        ;; Make sure there is a generic and the byte-compiler sees it.
 125        (defgeneric ,method ,args)
 126        (eieio--defmethod ',method ',key ',class #',code))))
 127
 128 (defun eieio--generic-static-symbol-specializers (tag &rest _)
 129   (cl-assert (or (null tag) (eieio--class-p tag)))
 130   (when (eieio--class-p tag)
 131     (let ((superclasses (eieio--generic-subclass-specializers tag))
 132           (specializers ()))
 133       (dolist (superclass superclasses)
 134         (push superclass specializers)
 135         (push `(eieio--static ,(cadr superclass)) specializers))
 136       (nreverse specializers))))
 137
 138 (cl-generic-define-generalizer eieio--generic-static-symbol-generalizer
 139   ;; Give it a slightly higher priority than `subclass' so that the
 140   ;; interleaved list comes before subclass's non-interleaved list.
 141   61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
 142   #'eieio--generic-static-symbol-specializers)
 143 (cl-generic-define-generalizer eieio--generic-static-object-generalizer
 144   ;; Give it a slightly higher priority than `class' so that the
 145   ;; interleaved list comes before the class's non-interleaved list.
 146   51 #'cl--generic-struct-tag
 147   (lambda (tag &rest _)
 148     (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
 149          (eieio--class-p tag)
 150          (let ((superclasses (eieio--class-precedence-list tag))
 151                (specializers ()))
 152            (dolist (superclass superclasses)
 153              (setq superclass (eieio--class-name superclass))
 154              (push superclass specializers)
 155              (push `(eieio--static ,superclass) specializers))
 156            (nreverse specializers)))))
 157
 158 (cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
 159   (list eieio--generic-static-symbol-generalizer
 160         eieio--generic-static-object-generalizer))
 161
 162 ;;;###autoload
 163 (defun eieio--defgeneric-init-form (method doc-string)
 164   (if doc-string (put method 'function-documentation doc-string))
 165   (if (memq method '(no-next-method no-applicable-method))
 166       (symbol-function method)
 167     (let ((generic (cl-generic-ensure-function method)))
 168       (symbol-function (cl--generic-name generic)))))
 169
 170 ;;;###autoload
 171 (defun eieio--defmethod (method kind argclass code)
 172   (setq kind (intern (downcase (symbol-name kind))))
 173   (let* ((specializer (if (not (eq kind :static))
 174                           (or argclass t)
 175                         (setq kind nil)
 176                         `(eieio--static ,argclass)))
 177          (uses-cnm (not (memq kind '(:before :after))))
 178          (specializers `((arg ,specializer)))
 179          (code
 180           ;; Backward compatibility for `no-next-method' and
 181           ;; `no-applicable-method', which have slightly different calling
 182           ;; convention than their cl-generic counterpart.
 183           (pcase method
 184             (`no-next-method
 185              (setq method 'cl-no-next-method)
 186              (setq specializers `(generic method ,@specializers))
 187              (lambda (_generic _method &rest args) (apply code args)))
 188             (`no-applicable-method
 189              (setq method 'cl-no-applicable-method)
 190              (setq specializers `(generic ,@specializers))
 191              (lambda (generic arg &rest args) (apply code arg generic args)))
 192             (_ code))))
 193     (cl-generic-define-method
 194      method (unless (memq kind '(nil :primary)) (list kind))
 195      specializers uses-cnm
 196      (if uses-cnm
 197          (let* ((docstring (documentation code 'raw))
 198                 (args (help-function-arglist code 'preserve-names))
 199                 (doc-only (if docstring
 200                               (let ((split (help-split-fundoc docstring nil)))
 201                                 (if split (cdr split) docstring)))))
 202            (lambda (cnm &rest args)
 203              (:documentation
 204               (help-add-fundoc-usage doc-only (cons 'cl-cnm args)))
 205              (cl-letf (((symbol-function 'call-next-method) cnm)
 206                        ((symbol-function 'next-method-p)
 207                         (lambda () (cl--generic-isnot-nnm-p cnm))))
 208                (apply code args))))
 209        code))
 210     ;; The old EIEIO code did not signal an error when there are methods
 211     ;; applicable but only of the before/after kind.  So if we add a :before
 212     ;; or :after, make sure there's a matching dummy primary.
 213     (when (and (memq kind '(:before :after))
 214                ;; FIXME: Use `cl-find-method'?
 215                (not (cl-find-method method ()
 216                                     (mapcar (lambda (arg)
 217                                               (if (consp arg) (nth 1 arg) t))
 218                                             specializers))))
 219       (cl-generic-define-method method () specializers t
 220                                 (lambda (cnm &rest args)
 221                                   (if (cl--generic-isnot-nnm-p cnm)
 222                                       (apply cnm args)))))
 223     method))
 224
 225 ;; Compatibility with code which tries to catch `no-method-definition' errors.
 226 (push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
 227
 228 (defun generic-p (fname) (not (null (cl--generic fname))))
 229
 230 (defun no-next-method (&rest args)
 231   (declare (obsolete cl-no-next-method "25.1"))
 232   (apply #'cl-no-next-method 'unknown nil args))
 233
 234 (defun no-applicable-method (object method &rest args)
 235   (declare (obsolete cl-no-applicable-method "25.1"))
 236   (apply #'cl-no-applicable-method method object args))
 237
 238 (define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
 239 (defun next-method-p ()
 240   (declare (obsolete cl-next-method-p "25.1"))
 241   ;; EIEIO's `next-method-p' just returned nil when called in an
 242   ;; invalid context.
 243   (message "next-method-p called outside of a primary or around method")
 244   nil)
 245
 246 ;;;###autoload
 247 (defun eieio-defmethod (method args)
 248   "Obsolete work part of an old version of the `defmethod' macro."
 249   (declare (obsolete cl-defmethod "24.1"))
 250   (eval `(defmethod ,method ,@args))
 251   method)
 252
 253 ;;;###autoload
 254 (defun eieio-defgeneric (method doc-string)
 255   "Obsolete work part of an old version of the `defgeneric' macro."
 256   (declare (obsolete cl-defgeneric "24.1"))
 257   (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
 258   ;; Return the method
 259   'method)
 260
 261 ;;;###autoload
 262 (defun eieio-defclass (cname superclasses slots options)
 263   (declare (obsolete eieio-defclass-internal "25.1"))
 264   (eval `(defclass ,cname ,superclasses ,slots ,@options)))
 265
 266
 267 ;; Local Variables:
 268 ;; generated-autoload-file: "eieio-loaddefs.el"
 269 ;; End:
 270
 271 (provide 'eieio-compat)
 272
 273 ;;; eieio-compat.el ends here