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