1 ;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*-
3 ;; Copyright (C) 1995-1996, 1998-2017 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
26 ;; Backward compatibility definition of old EIEIO functions in
27 ;; terms of newer equivalent.
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
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
49 (put 'eieio--defalias
'byte-hunk-handler
50 #'byte-compile-file-form-defalias
) ;;(get 'defalias 'byte-hunk-handler)
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
)))
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
77 ,(if doc-string
(help-add-fundoc-usage doc-string args
)))))
80 (defmacro defmethod
(method &rest args
)
81 "Create a new METHOD through `defgeneric' with ARGS.
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
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.
101 (defmethod mymethod [:before | :primary | :after | :static]
102 ((typearg class-name) arg2 &optional opt &rest rest)
105 (declare (doc-string 3) (obsolete cl-defmethod
"25.1")
107 (&define
; this means we are defining something
108 [&or name
("setf" name
:name setf
)]
109 ;; ^^ This is the methods symbol
110 [ &optional symbolp
] ; this is key :before etc
111 cl-generic-method-args
; arguments
112 [ &optional stringp
] ; documentation string
113 def-body
; part to be debugged
115 (let* ((key (if (keywordp (car args
)) (pop args
)))
118 (fargs (if (consp arg1
)
119 (cons (car arg1
) (cdr params
))
121 (class (if (consp arg1
) (nth 1 arg1
)))
122 (code `(lambda ,fargs
,@(cdr args
))))
124 ;; Make sure there is a generic and the byte-compiler sees it.
125 (defgeneric ,method
,args
)
126 (eieio--defmethod ',method
',key
',class
#',code
))))
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
))
133 (dolist (superclass superclasses
)
134 (push superclass specializers
)
135 (push `(eieio--static ,(cadr superclass
)) specializers
))
136 (nreverse specializers
))))
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
) (setq tag
(cl--find-class tag
))
150 (let ((superclasses (eieio--class-precedence-list tag
))
152 (dolist (superclass superclasses
)
153 (setq superclass
(eieio--class-name superclass
))
154 (push superclass specializers
)
155 (push `(eieio--static ,superclass
) specializers
))
156 (nreverse specializers
)))))
158 (cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static
)))
159 (list eieio--generic-static-symbol-generalizer
160 eieio--generic-static-object-generalizer
))
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 (or (symbol-function (cl--generic-name generic
))
169 (cl--generic-make-function 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
)
193 (apply code arg
(cl--generic-name generic
) (cons arg args
))))
195 (cl-generic-define-method
196 method
(unless (memq kind
'(nil :primary
)) (list kind
))
197 specializers uses-cnm
199 (let* ((docstring (documentation code
'raw
))
200 (args (help-function-arglist code
'preserve-names
))
201 (doc-only (if docstring
202 (let ((split (help-split-fundoc docstring nil
)))
203 (if split
(cdr split
) docstring
)))))
204 (lambda (cnm &rest args
)
206 (help-add-fundoc-usage doc-only
(cons 'cl-cnm args
)))
207 (cl-letf (((symbol-function 'call-next-method
) cnm
)
208 ((symbol-function 'next-method-p
)
209 (lambda () (cl--generic-isnot-nnm-p cnm
))))
212 ;; The old EIEIO code did not signal an error when there are methods
213 ;; applicable but only of the before/after kind. So if we add a :before
214 ;; or :after, make sure there's a matching dummy primary.
215 (when (and (memq kind
'(:before
:after
))
216 ;; FIXME: Use `cl-find-method'?
217 (not (cl-find-method method
()
218 (mapcar (lambda (arg)
219 (if (consp arg
) (nth 1 arg
) t
))
221 (cl-generic-define-method method
() specializers t
222 (lambda (cnm &rest args
)
223 (if (cl--generic-isnot-nnm-p cnm
)
227 ;; Compatibility with code which tries to catch `no-method-definition' errors.
228 (push 'no-method-definition
(get 'cl-no-applicable-method
'error-conditions
))
230 (defun generic-p (fname) (not (null (cl--generic fname
))))
232 (defun no-next-method (&rest args
)
233 (declare (obsolete cl-no-next-method
"25.1"))
234 (apply #'cl-no-next-method
'unknown nil args
))
236 (defun no-applicable-method (object method
&rest args
)
237 (declare (obsolete cl-no-applicable-method
"25.1"))
238 (apply #'cl-no-applicable-method method object args
))
240 (define-obsolete-function-alias 'call-next-method
'cl-call-next-method
"25.1")
241 (defun next-method-p ()
242 (declare (obsolete cl-next-method-p
"25.1"))
243 ;; EIEIO's `next-method-p' just returned nil when called in an
245 (message "next-method-p called outside of a primary or around method")
249 (defun eieio-defmethod (method args
)
250 "Obsolete work part of an old version of the `defmethod' macro."
251 (declare (obsolete cl-defmethod
"24.1"))
252 (eval `(defmethod ,method
,@args
))
256 (defun eieio-defgeneric (method doc-string
)
257 "Obsolete work part of an old version of the `defgeneric' macro."
258 (declare (obsolete cl-defgeneric
"24.1"))
259 (eval `(defgeneric ,method
(x) ,@(if doc-string
`(,doc-string
))))
264 (defun eieio-defclass (cname superclasses slots options
)
265 (declare (obsolete eieio-defclass-internal
"25.1"))
266 (eval `(defclass ,cname
,superclasses
,slots
,@options
)))
270 ;; generated-autoload-file: "eieio-loaddefs.el"
273 (provide 'eieio-compat
)
275 ;;; eieio-compat.el ends here