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