1 ;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*-
3 ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
8 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;; Backward compatibility definition of old EIEIO functions in
26 ;; terms of newer equivalent.
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
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
48 (put 'eieio--defalias 'byte-hunk-handler
49 #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
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)))
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
76 ,(if doc-string (help-add-fundoc-usage doc-string args)))))
79 (defmacro defmethod (method &rest args)
80 "Create a new METHOD through `defgeneric' with ARGS.
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
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.
100 (defmethod mymethod [:before | :primary | :after | :static]
101 ((typearg class-name) arg2 &optional opt &rest rest)
104 (declare (doc-string 3) (obsolete cl-defmethod "25.1")
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
111 [ &optional stringp ] ; documentation string
112 def-body ; part to be debugged
114 (let* ((key (if (keywordp (car args)) (pop args)))
117 (fargs (if (consp arg1)
118 (cons (car arg1) (cdr params))
120 (class (if (consp arg1) (nth 1 arg1)))
121 (code `(lambda ,fargs ,@(cdr args))))
123 ;; Make sure there is a generic and the byte-compiler sees it.
124 (defgeneric ,method ,args)
125 (eieio--defmethod ',method ',key ',class #',code))))
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))
132 (dolist (superclass superclasses)
133 (push superclass specializers)
134 (push `(eieio--static ,(cadr superclass)) specializers))
135 (nreverse specializers))))
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) (cl--find-class ,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
149 (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
151 (let ((superclasses (eieio--class-precedence-list tag))
153 (dolist (superclass superclasses)
154 (setq superclass (eieio--class-name superclass))
155 (push superclass specializers)
156 (push `(eieio--static ,superclass) specializers))
157 (nreverse specializers))))))
159 (cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
160 (list eieio--generic-static-symbol-generalizer
161 eieio--generic-static-object-generalizer))
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)))))
172 (defun eieio--defmethod (method kind argclass code)
173 (setq kind (intern (downcase (symbol-name kind))))
174 (let* ((specializer (if (not (eq kind :static))
177 `(eieio--static ,argclass)))
178 (uses-cnm (not (memq kind '(:before :after))))
179 (specializers `((arg ,specializer)))
181 ;; Backward compatibility for `no-next-method' and
182 ;; `no-applicable-method', which have slightly different calling
183 ;; convention than their cl-generic counterpart.
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)))
194 (cl-generic-define-method
195 method (unless (memq kind '(nil :primary)) (list kind))
196 specializers 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)
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))))
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))
220 (cl-generic-define-method method () specializers t
221 (lambda (cnm &rest args)
222 (if (cl--generic-isnot-nnm-p cnm)
226 ;; Compatibility with code which tries to catch `no-method-definition' errors.
227 (push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
229 (defun generic-p (fname) (not (null (cl--generic fname))))
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))
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))
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
244 (message "next-method-p called outside of a primary or around method")
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))
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))))
263 (defun eieio-defclass (cname superclasses slots options)
264 (declare (obsolete eieio-defclass-internal "25.1"))
265 (eval `(defclass ,cname ,superclasses ,slots ,@options)))
269 ;; generated-autoload-file: "eieio-core.el"
272 (provide 'eieio-compat)
274 ;;; eieio-compat.el ends here