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
   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 (defun eieio--generic-static-symbol-specializers (tag)
 128   (cl-assert (or (null tag) (eieio--class-p tag)))
 129   (when (eieio--class-p tag)
 130     (let ((superclasses (eieio--generic-subclass-specializers tag))
 131           (specializers ()))
 132       (dolist (superclass superclasses)
 133         (push superclass specializers)
 134         (push `(eieio--static ,(cadr superclass)) specializers))
 135       (nreverse specializers))))
 136
 137 (defconst eieio--generic-static-symbol-generalizer
 138   (cl-generic-make-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) `(and (symbolp ,name) (eieio--class-v ,name)))
 142    #'eieio--generic-static-symbol-specializers))
 143 (defconst eieio--generic-static-object-generalizer
 144   (cl-generic-make-generalizer
 145    ;; Give it a slightly higher priority than `class' so that the
 146    ;; interleaved list comes before the class's non-interleaved list.
 147    51 #'cl--generic-struct-tag
 148    (lambda (tag)
 149      (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
 150           (eieio--class-p tag)
 151           (let ((superclasses (eieio--class-precedence-list tag))
 152                 (specializers ()))
 153             (dolist (superclass superclasses)
 154               (setq superclass (eieio--class-name superclass))
 155               (push superclass specializers)
 156               (push `(eieio--static ,superclass) specializers))
 157             (nreverse specializers))))))
 158
 159 (cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
 160   (list eieio--generic-static-symbol-generalizer
 161         eieio--generic-static-object-generalizer))
 162
 163 ;;;###autoload
 164 (defun eieio--defgeneric-init-form (method doc-string)
 165   (if doc-string (put method 'function-documentation doc-string))
 166   (if (memq method '(no-next-method no-applicable-method))
 167       (symbol-function method)
 168     (let ((generic (cl-generic-ensure-function method)))
 169       (symbol-function (cl--generic-name generic)))))
 170
 171 ;;;###autoload
 172 (defun eieio--defmethod (method kind argclass code)
 173   (setq kind (intern (downcase (symbol-name kind))))
 174   (let* ((specializer (if (not (eq kind :static))
 175                           (or argclass t)
 176                         (setq kind nil)
 177                         `(eieio--static ,argclass)))
 178          (uses-cnm (not (memq kind '(:before :after))))
 179          (specializers `((arg ,specializer)))
 180          (code
 181           ;; Backward compatibility for `no-next-method' and
 182           ;; `no-applicable-method', which have slightly different calling
 183           ;; convention than their cl-generic counterpart.
 184           (pcase method
 185             (`no-next-method
 186              (setq method 'cl-no-next-method)
 187              (setq specializers `(generic method ,@specializers))
 188              (lambda (_generic _method &rest args) (apply code args)))
 189             (`no-applicable-method
 190              (setq method 'cl-no-applicable-method)
 191              (setq specializers `(generic ,@specializers))
 192              (lambda (generic arg &rest args) (apply code arg generic args)))
 193             (_ code))))
 194     (cl-generic-define-method
 195      method (unless (memq kind '(nil :primary)) (list kind))
 196      specializers uses-cnm
 197      (if uses-cnm
 198          (let* ((docstring (documentation code 'raw))
 199                 (args (help-function-arglist code 'preserve-names))
 200                 (doc-only (if docstring
 201                               (let ((split (help-split-fundoc docstring nil)))
 202                                 (if split (cdr split) docstring)))))
 203            (lambda (cnm &rest args)
 204              (:documentation
 205               (help-add-fundoc-usage doc-only (cons 'cl-cnm args)))
 206              (cl-letf (((symbol-function 'call-next-method) cnm)
 207                        ((symbol-function 'next-method-p)
 208                         (lambda () (cl--generic-isnot-nnm-p cnm))))
 209                (apply code args))))
 210        code))
 211     ;; The old EIEIO code did not signal an error when there are methods
 212     ;; applicable but only of the before/after kind.  So if we add a :before
 213     ;; or :after, make sure there's a matching dummy primary.
 214     (when (and (memq kind '(:before :after))
 215                ;; FIXME: Use `cl-find-method'?
 216                (not (cl-find-method method ()
 217                                     (mapcar (lambda (arg)
 218                                               (if (consp arg) (nth 1 arg) t))
 219                                             specializers))))
 220       (cl-generic-define-method method () specializers t
 221                                 (lambda (cnm &rest args)
 222                                   (if (cl--generic-isnot-nnm-p cnm)
 223                                       (apply cnm args)))))
 224     method))
 225
 226 ;; Compatibility with code which tries to catch `no-method-definition' errors.
 227 (push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
 228
 229 (defun generic-p (fname) (not (null (cl--generic fname))))
 230
 231 (defun no-next-method (&rest args)
 232   (declare (obsolete cl-no-next-method "25.1"))
 233   (apply #'cl-no-next-method 'unknown nil args))
 234
 235 (defun no-applicable-method (object method &rest args)
 236   (declare (obsolete cl-no-applicable-method "25.1"))
 237   (apply #'cl-no-applicable-method method object args))
 238
 239 (define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
 240 (defun next-method-p ()
 241   (declare (obsolete cl-next-method-p "25.1"))
 242   ;; EIEIO's `next-method-p' just returned nil when called in an
 243   ;; invalid context.
 244   (message "next-method-p called outside of a primary or around method")
 245   nil)
 246
 247 ;;;###autoload
 248 (defun eieio-defmethod (method args)
 249   "Obsolete work part of an old version of the `defmethod' macro."
 250   (declare (obsolete cl-defmethod "24.1"))
 251   (eval `(defmethod ,method ,@args))
 252   method)
 253
 254 ;;;###autoload
 255 (defun eieio-defgeneric (method doc-string)
 256   "Obsolete work part of an old version of the `defgeneric' macro."
 257   (declare (obsolete cl-defgeneric "24.1"))
 258   (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
 259   ;; Return the method
 260   'method)
 261
 262 ;;;###autoload
 263 (defun eieio-defclass (cname superclasses slots options)
 264   (declare (obsolete eieio-defclass-internal "25.1"))
 265   (eval `(defclass ,cname ,superclasses ,slots ,@options)))
 266
 267
 268 ;; Local Variables:
 269 ;; generated-autoload-file: "eieio-core.el"
 270 ;; End:
 271
 272 (provide 'eieio-compat)
 273
 274 ;;; eieio-compat.el ends here