aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2015-01-21 14:39:06 -0500
committerStefan Monnier2015-01-21 14:39:06 -0500
commit59e7fe6d0c6988687b53c279941c9ebb3f887eed (patch)
treeb5330cedb77c370aa00c5039a6c7c14fca6f5fe9
parent41efcf4db1589c2141ace6b9c3c15aa0386ecf95 (diff)
downloademacs-59e7fe6d0c6988687b53c279941c9ebb3f887eed.tar.gz
emacs-59e7fe6d0c6988687b53c279941c9ebb3f887eed.zip
* lisp/emacs-lisp/eieio*.el: Fix up warnings and improve compatibility
Fixes: debbugs:19645 * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Add support for `declare'. (cl--generic-setf-rewrite): Setup the setf expander right away. (cl-defmethod): Make sure the setf expander is setup before we expand the body. (cl-defmethod): Silence byte-compiler warnings. (cl-generic-define-method): Shuffle code to change return value. (cl--generic-method-info): New function, extracted from cl--generic-describe. (cl--generic-describe): Use it. * lisp/emacs-lisp/eieio-speedbar.el: * lisp/emacs-lisp/eieio-datadebug.el: * lisp/emacs-lisp/eieio-custom.el: * lisp/emacs-lisp/eieio-base.el: Use cl-defmethod. * lisp/emacs-lisp/eieio-compat.el (eieio--defmethod): Avoid no-next-method errors when there's a `before' but no `primary'. (next-method-p): Return nil rather than signal an error. (eieio-defgeneric): Remove bogus (fboundp 'method). * lisp/emacs-lisp/eieio-opt.el: Adapt to cl-generic. (eieio--specializers-apply-to-class-p): New function. (eieio-all-generic-functions): Use it. (eieio-method-documentation): Use it as well as cl--generic-method-info. Change format of return value. (eieio-help-class): Adapt accordingly. * lisp/emacs-lisp/eieio.el: Use cl-defmethod. (defclass): Generate cl-defmethod calls; use setf methods for :accessor. (eieio-object-name-string): Declare as obsolete. * test/automated/cl-generic-tests.el (setf cl--generic-2): Make sure the setf can be used already in the body of the method.
-rw-r--r--lisp/ChangeLog33
-rw-r--r--lisp/emacs-lisp/cl-generic.el122
-rw-r--r--lisp/emacs-lisp/eieio-base.el36
-rw-r--r--lisp/emacs-lisp/eieio-compat.el33
-rw-r--r--lisp/emacs-lisp/eieio-custom.el12
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el4
-rw-r--r--lisp/emacs-lisp/eieio-opt.el113
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el20
-rw-r--r--lisp/emacs-lisp/eieio.el89
-rw-r--r--test/ChangeLog11
-rw-r--r--test/automated/cl-generic-tests.el5
-rw-r--r--test/automated/eieio-test-methodinvoke.el2
12 files changed, 275 insertions, 205 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 65c068425f9..d13bacfd965 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,36 @@
12015-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/eieio.el: Use cl-defmethod.
4 (defclass): Generate cl-defmethod calls; use setf methods for :accessor.
5 (eieio-object-name-string): Declare as obsolete.
6
7 * emacs-lisp/eieio-opt.el: Adapt to cl-generic.
8 (eieio--specializers-apply-to-class-p): New function.
9 (eieio-all-generic-functions): Use it.
10 (eieio-method-documentation): Use it as well as cl--generic-method-info.
11 Change format of return value.
12 (eieio-help-class): Adapt accordingly.
13
14 * emacs-lisp/eieio-compat.el (eieio--defmethod): Avoid no-next-method
15 errors when there's a `before' but no `primary' (bug#19645).
16 (next-method-p): Return nil rather than signal an error.
17 (eieio-defgeneric): Remove bogus (fboundp 'method).
18
19 * emacs-lisp/eieio-speedbar.el:
20 * emacs-lisp/eieio-datadebug.el:
21 * emacs-lisp/eieio-custom.el:
22 * emacs-lisp/eieio-base.el: Use cl-defmethod.
23
24 * emacs-lisp/cl-generic.el (cl-defgeneric): Add support for `declare'.
25 (cl--generic-setf-rewrite): Setup the setf expander right away.
26 (cl-defmethod): Make sure the setf expander is setup before we expand
27 the body.
28 (cl-defmethod): Silence byte-compiler warnings.
29 (cl-generic-define-method): Shuffle code to change return value.
30 (cl--generic-method-info): New function, extracted from
31 cl--generic-describe.
32 (cl--generic-describe): Use it.
33
12015-01-21 Dmitry Gutov <dgutov@yandex.ru> 342015-01-21 Dmitry Gutov <dgutov@yandex.ru>
2 35
3 * progmodes/xref.el (xref--xref-buffer-mode-map): Define before 36 * progmodes/xref.el (xref--xref-buffer-mode-map): Define before
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 3bbddfc45a1..8dee9a38ab0 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -98,19 +98,20 @@ They should be sorted from most specific to least specific.")
98 (:constructor cl--generic-make 98 (:constructor cl--generic-make
99 (name &optional dispatches method-table)) 99 (name &optional dispatches method-table))
100 (:predicate nil)) 100 (:predicate nil))
101 (name nil :read-only t) ;Pointer back to the symbol. 101 (name nil :type symbol :read-only t) ;Pointer back to the symbol.
102 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index 102 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
103 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) 103 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
104 ;; where the EXPs are expressions (to be `or'd together) to compute the tag 104 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
105 ;; on which to dispatch and PRIORITY is the priority of each expression to 105 ;; on which to dispatch and PRIORITY is the priority of each expression to
106 ;; decide in which order to sort them. 106 ;; decide in which order to sort them.
107 ;; The most important dispatch is last in the list (and the least is first). 107 ;; The most important dispatch is last in the list (and the least is first).
108 dispatches 108 (dispatches nil :type (list-of (cons natnum (list-of tagcode))))
109 ;; `method-table' is a list of 109 ;; `method-table' is a list of
110 ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where 110 ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
111 ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method' 111 ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
112 ;; (and hence expects an extra argument holding the next-method). 112 ;; (and hence expects an extra argument holding the next-method).
113 method-table) 113 (method-table nil :type (list-of (cons (cons (list-of type) keyword)
114 (cons boolean function)))))
114 115
115(defmacro cl--generic (name) 116(defmacro cl--generic (name)
116 `(get ,name 'cl--generic)) 117 `(get ,name 'cl--generic))
@@ -134,15 +135,16 @@ They should be sorted from most specific to least specific.")
134 generic)) 135 generic))
135 136
136(defun cl--generic-setf-rewrite (name) 137(defun cl--generic-setf-rewrite (name)
137 (let ((setter (intern (format "cl-generic-setter--%s" name)))) 138 (let* ((setter (intern (format "cl-generic-setter--%s" name)))
138 (cons setter 139 (exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
139 `(eval-and-compile 140 ;; (when (get ',name 'gv-expander)
140 (unless (eq ',setter (get ',name 'cl-generic-setter)) 141 ;; (error "gv-expander conflicts with (setf %S)" ',name))
141 ;; (when (get ',name 'gv-expander) 142 (setf (get ',name 'cl-generic-setter) ',setter)
142 ;; (error "gv-expander conflicts with (setf %S)" ',name)) 143 (gv-define-setter ,name (val &rest args)
143 (setf (get ',name 'cl-generic-setter) ',setter) 144 (cons ',setter (cons val args))))))
144 (gv-define-setter ,name (val &rest args) 145 ;; Make sure `setf' can be used right away, e.g. in the body of the method.
145 (cons ',setter (cons val args)))))))) 146 (eval exp t)
147 (cons setter exp)))
146 148
147;;;###autoload 149;;;###autoload
148(defmacro cl-defgeneric (name args &rest options-and-methods) 150(defmacro cl-defgeneric (name args &rest options-and-methods)
@@ -151,8 +153,9 @@ DOC-STRING is the base documentation for this class. A generic
151function has no body, as its purpose is to decide which method body 153function has no body, as its purpose is to decide which method body
152is appropriate to use. Specific methods are defined with `cl-defmethod'. 154is appropriate to use. Specific methods are defined with `cl-defmethod'.
153With this implementation the ARGS are currently ignored. 155With this implementation the ARGS are currently ignored.
154OPTIONS-AND-METHODS is currently only used to specify the docstring, 156OPTIONS-AND-METHODS currently understands:
155via (:documentation DOCSTRING)." 157- (:documentation DOCSTRING)
158- (declare DECLARATIONS)"
156 (declare (indent 2) (doc-string 3)) 159 (declare (indent 2) (doc-string 3))
157 (let* ((docprop (assq :documentation options-and-methods)) 160 (let* ((docprop (assq :documentation options-and-methods))
158 (doc (cond ((stringp (car-safe options-and-methods)) 161 (doc (cond ((stringp (car-safe options-and-methods))
@@ -161,13 +164,26 @@ via (:documentation DOCSTRING)."
161 (prog1 164 (prog1
162 (cadr docprop) 165 (cadr docprop)
163 (setq options-and-methods 166 (setq options-and-methods
164 (delq docprop options-and-methods))))))) 167 (delq docprop options-and-methods))))))
168 (declarations (assq 'declare options-and-methods)))
169 (when declarations
170 (setq options-and-methods
171 (delq declarations options-and-methods)))
165 `(progn 172 `(progn
166 ,(when (eq 'setf (car-safe name)) 173 ,(when (eq 'setf (car-safe name))
167 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite 174 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
168 (cadr name)))) 175 (cadr name))))
169 (setq name setter) 176 (setq name setter)
170 code)) 177 code))
178 ,@(mapcar (lambda (declaration)
179 (let ((f (cdr (assq (car declaration)
180 defun-declarations-alist))))
181 (cond
182 (f (apply (car f) name args (cdr declaration)))
183 (t (message "Warning: Unknown defun property `%S' in %S"
184 (car declaration) name)
185 nil))))
186 (cdr declarations))
171 (defalias ',name 187 (defalias ',name
172 (cl-generic-define ',name ',args ',options-and-methods) 188 (cl-generic-define ',name ',args ',options-and-methods)
173 ,(help-add-fundoc-usage doc args))))) 189 ,(help-add-fundoc-usage doc args)))))
@@ -292,18 +308,19 @@ which case this method will be invoked when the argument is `eql' to VAL.
292 list ; arguments 308 list ; arguments
293 [ &optional stringp ] ; documentation string 309 [ &optional stringp ] ; documentation string
294 def-body))) ; part to be debugged 310 def-body))) ; part to be debugged
295 (let ((qualifiers nil)) 311 (let ((qualifiers nil)
312 (setfizer (if (eq 'setf (car-safe name))
313 ;; Call it before we call cl--generic-lambda.
314 (cl--generic-setf-rewrite (cadr name)))))
296 (while (keywordp args) 315 (while (keywordp args)
297 (push args qualifiers) 316 (push args qualifiers)
298 (setq args (pop body))) 317 (setq args (pop body)))
299 (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after)))) 318 (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
300 (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm))) 319 (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
301 `(progn 320 `(progn
302 ,(when (eq 'setf (car-safe name)) 321 ,(when setfizer
303 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite 322 (setq name (car setfizer))
304 (cadr name)))) 323 (cdr setfizer))
305 (setq name setter)
306 code))
307 ,(and (get name 'byte-obsolete-info) 324 ,(and (get name 'byte-obsolete-info)
308 (or (not (fboundp 'byte-compile-warning-enabled-p)) 325 (or (not (fboundp 'byte-compile-warning-enabled-p))
309 (byte-compile-warning-enabled-p 'obsolete)) 326 (byte-compile-warning-enabled-p 'obsolete))
@@ -311,6 +328,11 @@ which case this method will be invoked when the argument is `eql' to VAL.
311 (macroexp--warn-and-return 328 (macroexp--warn-and-return
312 (macroexp--obsolete-warning name obsolete "generic function") 329 (macroexp--obsolete-warning name obsolete "generic function")
313 nil))) 330 nil)))
331 ;; You could argue that `defmethod' modifies rather than defines the
332 ;; function, so warnings like "not known to be defined" are fair game.
333 ;; But in practice, it's common to use `cl-defmethod'
334 ;; without a previous `cl-defgeneric'.
335 (declare-function ,name "")
314 (cl-generic-define-method ',name ',qualifiers ',args 336 (cl-generic-define-method ',name ',qualifiers ',args
315 ,uses-cnm ,fun))))) 337 ,uses-cnm ,fun)))))
316 338
@@ -344,14 +366,14 @@ which case this method will be invoked when the argument is `eql' to VAL.
344 (if me (setcdr me (cons uses-cnm function)) 366 (if me (setcdr me (cons uses-cnm function))
345 (setf (cl--generic-method-table generic) 367 (setf (cl--generic-method-table generic)
346 (cons `(,key ,uses-cnm . ,function) mt))) 368 (cons `(,key ,uses-cnm . ,function) mt)))
347 ;; For aliases, cl--generic-name gives us the actual name. 369 (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
370 current-load-list :test #'equal)
348 (let ((gfun (cl--generic-make-function generic)) 371 (let ((gfun (cl--generic-make-function generic))
349 ;; Prevent `defalias' from recording this as the definition site of 372 ;; Prevent `defalias' from recording this as the definition site of
350 ;; the generic function. 373 ;; the generic function.
351 current-load-list) 374 current-load-list)
352 (defalias (cl--generic-name generic) gfun)) 375 ;; For aliases, cl--generic-name gives us the actual name.
353 (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) 376 (defalias (cl--generic-name generic) gfun))))
354 current-load-list :test #'equal)))
355 377
356(defmacro cl--generic-with-memoization (place &rest code) 378(defmacro cl--generic-with-memoization (place &rest code)
357 (declare (indent 1) (debug t)) 379 (declare (indent 1) (debug t))
@@ -448,8 +470,12 @@ for all those different tags in the method-cache.")
448 ;; We don't currently have "method objects" like CLOS 470 ;; We don't currently have "method objects" like CLOS
449 ;; does so we can't really do it the CLOS way. 471 ;; does so we can't really do it the CLOS way.
450 ;; The closest would be to pass the lambda corresponding 472 ;; The closest would be to pass the lambda corresponding
451 ;; to the method, but the caller wouldn't be able to do 473 ;; to the method, or maybe the ((SPECIALIZERS
452 ;; much with it anyway. So we pass nil for now. 474 ;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method
475 ;; table, but the caller wouldn't be able to do much with
476 ;; it anyway. So we pass nil for now.
477 ;; FIXME: signal `no-primary-method' if there's
478 ;; no primary.
453 (apply #'cl-no-next-method generic-name nil args))) 479 (apply #'cl-no-next-method generic-name nil args)))
454 ;; We use `cdr' to drop the `uses-cnm' annotations. 480 ;; We use `cdr' to drop the `uses-cnm' annotations.
455 (before 481 (before
@@ -566,6 +592,24 @@ Can only be used from within the lexical body of a primary or around method."
566 (add-to-list 'find-function-regexp-alist 592 (add-to-list 'find-function-regexp-alist
567 `(cl-defmethod . ,#'cl--generic-search-method))) 593 `(cl-defmethod . ,#'cl--generic-search-method)))
568 594
595(defun cl--generic-method-info (method)
596 (pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method))
597 (let* ((args (help-function-arglist function 'names))
598 (docstring (documentation function))
599 (doconly (if docstring
600 (let ((split (help-split-fundoc docstring nil)))
601 (if split (cdr split) docstring))))
602 (combined-args ()))
603 (if uses-cnm (setq args (cdr args)))
604 (dolist (specializer specializers)
605 (let ((arg (if (eq '&rest (car args))
606 (intern (format "arg%d" (length combined-args)))
607 (pop args))))
608 (push (if (eq specializer t) arg (list arg specializer))
609 combined-args)))
610 (setq combined-args (append (nreverse combined-args) args))
611 (list qualifier combined-args doconly))))
612
569(add-hook 'help-fns-describe-function-functions #'cl--generic-describe) 613(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
570(defun cl--generic-describe (function) 614(defun cl--generic-describe (function)
571 (let ((generic (if (symbolp function) (cl--generic function)))) 615 (let ((generic (if (symbolp function) (cl--generic function))))
@@ -575,25 +619,11 @@ Can only be used from within the lexical body of a primary or around method."
575 (insert "\n\nThis is a generic function.\n\n") 619 (insert "\n\nThis is a generic function.\n\n")
576 (insert (propertize "Implementations:\n\n" 'face 'bold)) 620 (insert (propertize "Implementations:\n\n" 'face 'bold))
577 ;; Loop over fanciful generics 621 ;; Loop over fanciful generics
578 (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method) 622 (dolist (method (cl--generic-method-table generic))
579 (cl--generic-method-table generic)) 623 (let* ((info (cl--generic-method-info method)))
580 (let* ((args (help-function-arglist method 'names))
581 (docstring (documentation method))
582 (doconly (if docstring
583 (let ((split (help-split-fundoc docstring nil)))
584 (if split (cdr split) docstring))))
585 (combined-args ()))
586 (if uses-cnm (setq args (cdr args)))
587 (dolist (specializer specializers)
588 (let ((arg (if (eq '&rest (car args))
589 (intern (format "arg%d" (length combined-args)))
590 (pop args))))
591 (push (if (eq specializer t) arg (list arg specializer))
592 combined-args)))
593 (setq combined-args (append (nreverse combined-args) args))
594 ;; FIXME: Add hyperlinks for the types as well. 624 ;; FIXME: Add hyperlinks for the types as well.
595 (insert (format "%S %S" qualifier combined-args)) 625 (insert (format "%S %S" (nth 0 info) (nth 1 info)))
596 (let* ((met-name (cons function specializers)) 626 (let* ((met-name (cons function (caar method)))
597 (file (find-lisp-object-file-name met-name 'cl-defmethod))) 627 (file (find-lisp-object-file-name met-name 'cl-defmethod)))
598 (when file 628 (when file
599 (insert " in `") 629 (insert " in `")
@@ -601,7 +631,7 @@ Can only be used from within the lexical body of a primary or around method."
601 'help-function-def met-name file 631 'help-function-def met-name file
602 'cl-defmethod) 632 'cl-defmethod)
603 (insert "'.\n"))) 633 (insert "'.\n")))
604 (insert "\n" (or doconly "Undocumented") "\n\n"))))))) 634 (insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
605 635
606;;; Support for (eql <val>) specializers. 636;;; Support for (eql <val>) specializers.
607 637
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 9931fbd114e..feb06711cb3 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -52,7 +52,7 @@ a parent instance. When a slot in the child is referenced, and has
52not been set, use values from the parent." 52not been set, use values from the parent."
53 :abstract t) 53 :abstract t)
54 54
55(defmethod slot-unbound ((object eieio-instance-inheritor) 55(cl-defmethod slot-unbound ((object eieio-instance-inheritor)
56 _class slot-name _fn) 56 _class slot-name _fn)
57 "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. 57 "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
58SLOT-NAME is the offending slot. FN is the function signaling the error." 58SLOT-NAME is the offending slot. FN is the function signaling the error."
@@ -61,16 +61,16 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
61 ;; method if the parent instance's slot is unbound. 61 ;; method if the parent instance's slot is unbound.
62 (eieio-oref (oref object parent-instance) slot-name) 62 (eieio-oref (oref object parent-instance) slot-name)
63 ;; Throw the regular signal. 63 ;; Throw the regular signal.
64 (call-next-method))) 64 (cl-call-next-method)))
65 65
66(defmethod clone ((obj eieio-instance-inheritor) &rest _params) 66(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params)
67 "Clone OBJ, initializing `:parent' to OBJ. 67 "Clone OBJ, initializing `:parent' to OBJ.
68All slots are unbound, except those initialized with PARAMS." 68All slots are unbound, except those initialized with PARAMS."
69 (let ((nobj (call-next-method))) 69 (let ((nobj (cl-call-next-method)))
70 (oset nobj parent-instance obj) 70 (oset nobj parent-instance obj)
71 nobj)) 71 nobj))
72 72
73(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) 73(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
74 slot) 74 slot)
75 "Return non-nil if the instance inheritor OBJECT's SLOT is bound. 75 "Return non-nil if the instance inheritor OBJECT's SLOT is bound.
76See `slot-boundp' for details on binding slots. 76See `slot-boundp' for details on binding slots.
@@ -103,7 +103,7 @@ Inheritors from this class must overload `tracking-symbol' which is
103a variable symbol used to store a list of all instances." 103a variable symbol used to store a list of all instances."
104 :abstract t) 104 :abstract t)
105 105
106(defmethod initialize-instance :AFTER ((this eieio-instance-tracker) 106(cl-defmethod initialize-instance :after ((this eieio-instance-tracker)
107 &rest _slots) 107 &rest _slots)
108 "Make sure THIS is in our master list of this class. 108 "Make sure THIS is in our master list of this class.
109Optional argument SLOTS are the initialization arguments." 109Optional argument SLOTS are the initialization arguments."
@@ -112,7 +112,7 @@ Optional argument SLOTS are the initialization arguments."
112 (if (not (memq this (symbol-value sym))) 112 (if (not (memq this (symbol-value sym)))
113 (set sym (append (symbol-value sym) (list this)))))) 113 (set sym (append (symbol-value sym) (list this))))))
114 114
115(defmethod delete-instance ((this eieio-instance-tracker)) 115(cl-defmethod delete-instance ((this eieio-instance-tracker))
116 "Remove THIS from the master list of this class." 116 "Remove THIS from the master list of this class."
117 (set (oref this tracking-symbol) 117 (set (oref this tracking-symbol)
118 (delq this (symbol-value (oref this tracking-symbol))))) 118 (delq this (symbol-value (oref this tracking-symbol)))))
@@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
140A singleton is a class which will only ever have one instance." 140A singleton is a class which will only ever have one instance."
141 :abstract t) 141 :abstract t)
142 142
143(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots) 143(cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots)
144 "Constructor for singleton CLASS. 144 "Constructor for singleton CLASS.
145NAME and SLOTS initialize the new object. 145NAME and SLOTS initialize the new object.
146This constructor guarantees that no matter how many you request, 146This constructor guarantees that no matter how many you request,
@@ -149,7 +149,7 @@ only one object ever exists."
149 ;; with class allocated slots or default values. 149 ;; with class allocated slots or default values.
150 (let ((old (oref-default class singleton))) 150 (let ((old (oref-default class singleton)))
151 (if (eq old eieio-unbound) 151 (if (eq old eieio-unbound)
152 (oset-default class singleton (call-next-method)) 152 (oset-default class singleton (cl-call-next-method))
153 old))) 153 old)))
154 154
155 155
@@ -198,7 +198,7 @@ object. For this reason, only slots which do not have an `:initarg'
198specified will not be saved." 198specified will not be saved."
199 :abstract t) 199 :abstract t)
200 200
201(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt 201(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
202 &optional name) 202 &optional name)
203 "Prepare to save THIS. Use in an `interactive' statement. 203 "Prepare to save THIS. Use in an `interactive' statement.
204Query user for file name with PROMPT if THIS does not yet specify 204Query user for file name with PROMPT if THIS does not yet specify
@@ -417,17 +417,17 @@ If no class is referenced there, then return nil."
417 ;; No match, not a class. 417 ;; No match, not a class.
418 nil))) 418 nil)))
419 419
420(defmethod object-write ((this eieio-persistent) &optional comment) 420(cl-defmethod object-write ((this eieio-persistent) &optional comment)
421 "Write persistent object THIS out to the current stream. 421 "Write persistent object THIS out to the current stream.
422Optional argument COMMENT is a header line comment." 422Optional argument COMMENT is a header line comment."
423 (call-next-method this (or comment (oref this file-header-line)))) 423 (cl-call-next-method this (or comment (oref this file-header-line))))
424 424
425(defmethod eieio-persistent-path-relative ((this eieio-persistent) file) 425(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
426 "For object THIS, make absolute file name FILE relative." 426 "For object THIS, make absolute file name FILE relative."
427 (file-relative-name (expand-file-name file) 427 (file-relative-name (expand-file-name file)
428 (file-name-directory (oref this file)))) 428 (file-name-directory (oref this file))))
429 429
430(defmethod eieio-persistent-save ((this eieio-persistent) &optional file) 430(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
431 "Save persistent object THIS to disk. 431 "Save persistent object THIS to disk.
432Optional argument FILE overrides the file name specified in the object 432Optional argument FILE overrides the file name specified in the object
433instance." 433instance."
@@ -474,21 +474,21 @@ instance."
474 "Object with a name." 474 "Object with a name."
475 :abstract t) 475 :abstract t)
476 476
477(defmethod eieio-object-name-string ((obj eieio-named)) 477(cl-defmethod eieio-object-name-string ((obj eieio-named))
478 "Return a string which is OBJ's name." 478 "Return a string which is OBJ's name."
479 (or (slot-value obj 'object-name) 479 (or (slot-value obj 'object-name)
480 (symbol-name (eieio-object-class obj)))) 480 (symbol-name (eieio-object-class obj))))
481 481
482(defmethod eieio-object-set-name-string ((obj eieio-named) name) 482(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
483 "Set the string which is OBJ's NAME." 483 "Set the string which is OBJ's NAME."
484 (eieio--check-type stringp name) 484 (eieio--check-type stringp name)
485 (eieio-oset obj 'object-name name)) 485 (eieio-oset obj 'object-name name))
486 486
487(defmethod clone ((obj eieio-named) &rest params) 487(cl-defmethod clone ((obj eieio-named) &rest params)
488 "Clone OBJ, initializing `:parent' to OBJ. 488 "Clone OBJ, initializing `:parent' to OBJ.
489All slots are unbound, except those initialized with PARAMS." 489All slots are unbound, except those initialized with PARAMS."
490 (let* ((newname (and (stringp (car params)) (pop params))) 490 (let* ((newname (and (stringp (car params)) (pop params)))
491 (nobj (apply #'call-next-method obj params)) 491 (nobj (apply #'cl-call-next-method obj params))
492 (nm (slot-value obj 'object-name))) 492 (nm (slot-value obj 'object-name)))
493 (eieio-oset obj 'object-name 493 (eieio-oset obj 'object-name
494 (or newname 494 (or newname
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 34c06c01763..c2dabf7f446 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -190,13 +190,27 @@ Summary:
190 (if split (cdr split) docstring)))) 190 (if split (cdr split) docstring))))
191 (new-docstring (help-add-fundoc-usage doc-only 191 (new-docstring (help-add-fundoc-usage doc-only
192 (cons 'cl-cnm args)))) 192 (cons 'cl-cnm args))))
193 ;; FIXME: ¡Add the new-docstring to those closures! 193 ;; FIXME: ¡Add new-docstring to those closures!
194 (lambda (cnm &rest args) 194 (lambda (cnm &rest args)
195 (cl-letf (((symbol-function 'call-next-method) cnm) 195 (cl-letf (((symbol-function 'call-next-method) cnm)
196 ((symbol-function 'next-method-p) 196 ((symbol-function 'next-method-p)
197 (lambda () (cl--generic-isnot-nnm-p cnm)))) 197 (lambda () (cl--generic-isnot-nnm-p cnm))))
198 (apply code args)))) 198 (apply code args))))
199 code)))) 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 (not (assoc (cons (mapcar (lambda (arg)
205 (if (consp arg) (nth 1 arg) t))
206 specializers)
207 :primary)
208 (cl--generic-method-table (cl--generic method)))))
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))
200 214
201;; Compatibility with code which tries to catch `no-method-definition' errors. 215;; Compatibility with code which tries to catch `no-method-definition' errors.
202(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) 216(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
@@ -212,7 +226,12 @@ Summary:
212 (apply #'cl-no-applicable-method method object args)) 226 (apply #'cl-no-applicable-method method object args))
213 227
214(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") 228(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
215(define-obsolete-function-alias 'next-method-p 'cl-next-method-p "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)
216 235
217;;;###autoload 236;;;###autoload
218(defun eieio-defmethod (method args) 237(defun eieio-defmethod (method args)
@@ -225,11 +244,9 @@ Summary:
225(defun eieio-defgeneric (method doc-string) 244(defun eieio-defgeneric (method doc-string)
226 "Obsolete work part of an old version of the `defgeneric' macro." 245 "Obsolete work part of an old version of the `defgeneric' macro."
227 (declare (obsolete cl-defgeneric "24.1")) 246 (declare (obsolete cl-defgeneric "24.1"))
228 ;; Don't do this over and over. 247 (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
229 (unless (fboundp 'method) 248 ;; Return the method
230 (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) 249 'method)
231 ;; Return the method
232 'method))
233 250
234;;;###autoload 251;;;###autoload
235(defun eieio-defclass (cname superclasses slots options) 252(defun eieio-defclass (cname superclasses slots options)
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 8ab74ae3352..0e0b31e4e7e 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -322,7 +322,7 @@ Optional argument IGNORE is an extraneous parameter."
322 ;; This is the same object we had before. 322 ;; This is the same object we had before.
323 obj)) 323 obj))
324 324
325(defmethod eieio-done-customizing ((_obj eieio-default-superclass)) 325(cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass))
326 "When applying change to a widget, call this method. 326 "When applying change to a widget, call this method.
327This method is called by the default widget-edit commands. 327This method is called by the default widget-edit commands.
328User made commands should also call this method when applying changes. 328User made commands should also call this method when applying changes.
@@ -345,7 +345,7 @@ Optional argument GROUP is the sub-group of slots to display."
345 "Major mode for customizing EIEIO objects. 345 "Major mode for customizing EIEIO objects.
346\\{eieio-custom-mode-map}") 346\\{eieio-custom-mode-map}")
347 347
348(defmethod eieio-customize-object ((obj eieio-default-superclass) 348(cl-defmethod eieio-customize-object ((obj eieio-default-superclass)
349 &optional group) 349 &optional group)
350 "Customize OBJ in a specialized custom buffer. 350 "Customize OBJ in a specialized custom buffer.
351To override call the `eieio-custom-widget-insert' to just insert the 351To override call the `eieio-custom-widget-insert' to just insert the
@@ -386,7 +386,7 @@ These groups are specified with the `:group' slot flag."
386 (make-local-variable 'eieio-cog) 386 (make-local-variable 'eieio-cog)
387 (setq eieio-cog g))) 387 (setq eieio-cog g)))
388 388
389(defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) 389(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
390 "Insert an Apply and Reset button into the object editor. 390 "Insert an Apply and Reset button into the object editor.
391Argument OBJ is the object being customized." 391Argument OBJ is the object being customized."
392 (widget-create 'push-button 392 (widget-create 'push-button
@@ -417,7 +417,7 @@ Argument OBJ is the object being customized."
417 (bury-buffer)) 417 (bury-buffer))
418 "Cancel")) 418 "Cancel"))
419 419
420(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) 420(cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
421 &rest flags) 421 &rest flags)
422 "Insert the widget used for editing object OBJ in the current buffer. 422 "Insert the widget used for editing object OBJ in the current buffer.
423Arguments FLAGS are widget compatible flags. 423Arguments FLAGS are widget compatible flags.
@@ -446,7 +446,7 @@ Must return the created widget."
446;; These functions provide the ability to create dynamic menus to 446;; These functions provide the ability to create dynamic menus to
447;; customize specific sections of an object. They do not hook directly 447;; customize specific sections of an object. They do not hook directly
448;; into a filter, but can be used to create easymenu vectors. 448;; into a filter, but can be used to create easymenu vectors.
449(defmethod eieio-customize-object-group ((obj eieio-default-superclass)) 449(cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass))
450 "Create a list of vectors for customizing sections of OBJ." 450 "Create a list of vectors for customizing sections of OBJ."
451 (mapcar (lambda (group) 451 (mapcar (lambda (group)
452 (vector (concat "Group " (symbol-name group)) 452 (vector (concat "Group " (symbol-name group))
@@ -457,7 +457,7 @@ Must return the created widget."
457(defvar eieio-read-custom-group-history nil 457(defvar eieio-read-custom-group-history nil
458 "History for the custom group reader.") 458 "History for the custom group reader.")
459 459
460(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) 460(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass))
461 "Do a completing read on the name of a customization group in OBJ. 461 "Do a completing read on the name of a customization group in OBJ.
462Return the symbol for the group, or nil" 462Return the symbol for the group, or nil"
463 (let ((g (eieio--class-option (eieio--object-class-object obj) 463 (let ((g (eieio--class-option (eieio--object-class-object obj)
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index ab8d41e4ac4..6534bd0fecf 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -79,7 +79,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
79;; 79;;
80;; Each object should have an opportunity to show stuff about itself. 80;; Each object should have an opportunity to show stuff about itself.
81 81
82(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) 82(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
83 prefix) 83 prefix)
84 "Insert the slots of OBJ into the current DDEBUG buffer." 84 "Insert the slots of OBJ into the current DDEBUG buffer."
85 (let ((inhibit-read-only t)) 85 (let ((inhibit-read-only t))
@@ -124,7 +124,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
124;; 124;;
125;; A generic function to run DDEBUG on an object and popup a new buffer. 125;; A generic function to run DDEBUG on an object and popup a new buffer.
126;; 126;;
127(defmethod data-debug-show ((obj eieio-default-superclass)) 127(cl-defmethod data-debug-show ((obj eieio-default-superclass))
128 "Run ddebug against any EIEIO object OBJ." 128 "Run ddebug against any EIEIO object OBJ."
129 (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) 129 (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
130 (data-debug-insert-object-slots obj "]")) 130 (data-debug-insert-object-slots obj "]"))
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 13ad120a9b5..a131b02ee16 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -122,29 +122,18 @@ If CLASS is actually an object, then also display current values of that object.
122 ;; Describe all the slots in this class. 122 ;; Describe all the slots in this class.
123 (eieio-help-class-slots class) 123 (eieio-help-class-slots class)
124 ;; Describe all the methods specific to this class. 124 ;; Describe all the methods specific to this class.
125 (let ((methods (eieio-all-generic-functions class)) 125 (let ((generics (eieio-all-generic-functions class)))
126 (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"]) 126 (when generics
127 counter doc)
128 (when methods
129 (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) 127 (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
130 (while methods 128 (dolist (generic generics)
131 (setq doc (eieio-method-documentation (car methods) class)) 129 (insert "`")
132 (insert "`") 130 (help-insert-xref-button (symbol-name generic) 'help-function generic)
133 (help-insert-xref-button (symbol-name (car methods)) 131 (insert "'")
134 'help-function (car methods)) 132 (pcase-dolist (`(,qualifier ,args ,doc)
135 (insert "'") 133 (eieio-method-documentation generic class))
136 (if (not doc) 134 (insert (format " %S %S\n" qualifier args)
137 (insert " Undocumented") 135 (or doc "")))
138 (setq counter 0) 136 (insert "\n\n")))))
139 (dolist (cur doc)
140 (when cur
141 (insert " " (aref type counter) " "
142 (prin1-to-string (car cur) (current-buffer))
143 "\n"
144 (or (cdr cur) "")))
145 (setq counter (1+ counter))))
146 (insert "\n\n")
147 (setq methods (cdr methods))))))
148 137
149(defun eieio-help-class-slots (class) 138(defun eieio-help-class-slots (class)
150 "Print help description for the slots in CLASS. 139 "Print help description for the slots in CLASS.
@@ -311,6 +300,20 @@ are not abstract."
311 (eieio-help-class ctr)) 300 (eieio-help-class ctr))
312 )))) 301 ))))
313 302
303(defun eieio--specializers-apply-to-class-p (specializers class)
304 "Return non-nil if a method with SPECIALIZERS applies to CLASS."
305 (let ((applies nil))
306 (dolist (specializer specializers)
307 (if (eq 'subclass (car-safe specializer))
308 (setq specializer (nth 1 specializer)))
309 ;; Don't include the methods that are "too generic", such as those
310 ;; applying to `eieio-default-superclass'.
311 (and (not (memq specializer '(t eieio-default-superclass)))
312 (class-p specializer)
313 (child-of-class-p class specializer)
314 (setq applies t)))
315 applies))
316
314(defun eieio-all-generic-functions (&optional class) 317(defun eieio-all-generic-functions (&optional class)
315 "Return a list of all generic functions. 318 "Return a list of all generic functions.
316Optional CLASS argument returns only those functions that contain 319Optional CLASS argument returns only those functions that contain
@@ -318,53 +321,31 @@ methods for CLASS."
318 (let ((l nil)) 321 (let ((l nil))
319 (mapatoms 322 (mapatoms
320 (lambda (symbol) 323 (lambda (symbol)
321 (let ((tree (get symbol 'eieio-method-hashtable))) 324 (let ((generic (and (fboundp symbol) (cl--generic symbol))))
322 (when tree 325 (and generic
323 ;; A symbol might be interned for that class in one of 326 (catch 'found
324 ;; these three slots in the method-obarray. 327 (if (null class) (throw 'found t))
325 (if (or (not class) 328 (pcase-dolist (`((,specializers . ,_qualifier) . ,_)
326 (car (gethash class (aref tree 0))) 329 (cl--generic-method-table generic))
327 (car (gethash class (aref tree 1))) 330 (if (eieio--specializers-apply-to-class-p
328 (car (gethash class (aref tree 2)))) 331 specializers class)
329 (setq l (cons symbol l))))))) 332 (throw 'found t))))
333 (push symbol l)))))
330 l)) 334 l))
331 335
332(defun eieio-method-documentation (generic class) 336(defun eieio-method-documentation (generic class)
333 "Return a list of the specific documentation of GENERIC for CLASS. 337 "Return info for all methods of GENERIC applicable to CLASS.
334If there is not an explicit method for CLASS in GENERIC, or if that 338The value returned is a list of elements of the form
335function has no documentation, then return nil." 339\(QUALIFIER ARGS DOC)."
336 (let ((tree (get generic 'eieio-method-hashtable))) 340 (let ((generic (cl--generic generic))
337 (when tree 341 (docs ()))
338 ;; A symbol might be interned for that class in one of 342 (when generic
339 ;; these three slots in the method-hashtable. 343 (dolist (method (cl--generic-method-table generic))
340 ;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static, 344 (pcase-let ((`((,specializers . ,_qualifier) . ,_) method))
341 ;; 1 for before, and 2 for primary (and 3 for after)? 345 (when (eieio--specializers-apply-to-class-p
342 (let ((before (car (gethash class (aref tree 0)))) 346 specializers class)
343 (primary (car (gethash class (aref tree 1)))) 347 (push (cl--generic-method-info method) docs)))))
344 (after (car (gethash class (aref tree 2))))) 348 docs))
345 (if (not (or before primary after))
346 nil
347 (list (if before
348 (cons (help-function-arglist before)
349 (documentation before))
350 nil)
351 (if primary
352 (cons (help-function-arglist primary)
353 (documentation primary))
354 nil)
355 (if after
356 (cons (help-function-arglist after)
357 (documentation after))
358 nil)))))))
359
360(defvar eieio-read-generic nil
361 "History of the `eieio-read-generic' prompt.")
362
363(defun eieio-read-generic (prompt &optional historyvar)
364 "Read a generic function from the minibuffer with PROMPT.
365Optional argument HISTORYVAR is the variable to use as history."
366 (intern (completing-read prompt obarray #'generic-p
367 t nil (or historyvar 'eieio-read-generic))))
368 349
369;;; METHOD STATS 350;;; METHOD STATS
370;; 351;;
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index b236f0f03e1..a1eabcf9700 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -196,19 +196,19 @@ that path."
196;; when no other methods are found, allowing multiple inheritance to work 196;; when no other methods are found, allowing multiple inheritance to work
197;; reliably with eieio-speedbar. 197;; reliably with eieio-speedbar.
198 198
199(defmethod eieio-speedbar-description (object) 199(cl-defmethod eieio-speedbar-description (object)
200 "Return a string describing OBJECT." 200 "Return a string describing OBJECT."
201 (eieio-object-name-string object)) 201 (eieio-object-name-string object))
202 202
203(defmethod eieio-speedbar-derive-line-path (_object) 203(cl-defmethod eieio-speedbar-derive-line-path (_object)
204 "Return the path which OBJECT has something to do with." 204 "Return the path which OBJECT has something to do with."
205 nil) 205 nil)
206 206
207(defmethod eieio-speedbar-object-buttonname (object) 207(cl-defmethod eieio-speedbar-object-buttonname (object)
208 "Return a string to use as a speedbar button for OBJECT." 208 "Return a string to use as a speedbar button for OBJECT."
209 (eieio-object-name-string object)) 209 (eieio-object-name-string object))
210 210
211(defmethod eieio-speedbar-make-tag-line (object depth) 211(cl-defmethod eieio-speedbar-make-tag-line (object depth)
212 "Insert a tag line into speedbar at point for OBJECT. 212 "Insert a tag line into speedbar at point for OBJECT.
213By default, all objects appear as simple TAGS with no need to inherit from 213By default, all objects appear as simple TAGS with no need to inherit from
214the special `eieio-speedbar' classes. Child classes should redefine this 214the special `eieio-speedbar' classes. Child classes should redefine this
@@ -221,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
221 'speedbar-tag-face 221 'speedbar-tag-face
222 depth)) 222 depth))
223 223
224(defmethod eieio-speedbar-handle-click (object) 224(cl-defmethod eieio-speedbar-handle-click (object)
225 "Handle a click action on OBJECT in speedbar. 225 "Handle a click action on OBJECT in speedbar.
226Any object can be represented as a tag in SPEEDBAR without special 226Any object can be represented as a tag in SPEEDBAR without special
227attributes. These default objects will be pulled up in a custom 227attributes. These default objects will be pulled up in a custom
@@ -285,7 +285,7 @@ Add one of the child classes to this class to the parent list of a class."
285 285
286;;; Methods to eieio-speedbar-* which do not need to be overridden 286;;; Methods to eieio-speedbar-* which do not need to be overridden
287;; 287;;
288(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) 288(cl-defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar)
289 depth) 289 depth)
290 "Insert a tag line into speedbar at point for OBJECT. 290 "Insert a tag line into speedbar at point for OBJECT.
291All objects a child of symbol `eieio-speedbar' can be created from 291All objects a child of symbol `eieio-speedbar' can be created from
@@ -321,12 +321,12 @@ Argument DEPTH is the depth at which the tag line is inserted."
321 (if exp 321 (if exp
322 (eieio-speedbar-expand object (1+ depth)))))) 322 (eieio-speedbar-expand object (1+ depth))))))
323 323
324(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth) 324(cl-defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth)
325 "Base method for creating tag lines for non-object children." 325 "Base method for creating tag lines for non-object children."
326 (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" 326 (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
327 (eieio-object-name object))) 327 (eieio-object-name object)))
328 328
329(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) 329(cl-defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
330 "Expand OBJECT at indentation DEPTH. 330 "Expand OBJECT at indentation DEPTH.
331Inserts a list of new tag lines representing expanded elements within 331Inserts a list of new tag lines representing expanded elements within
332OBJECT." 332OBJECT."
@@ -362,7 +362,7 @@ TOKEN is the object. INDENT is the current indentation level."
362 (t (error "Ooops... not sure what to do"))) 362 (t (error "Ooops... not sure what to do")))
363 (speedbar-center-buffer-smartly)) 363 (speedbar-center-buffer-smartly))
364 364
365(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) 365(cl-defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
366 "Return a description for a child of OBJ which is not an object." 366 "Return a description for a child of OBJ which is not an object."
367 (error "You must implement `eieio-speedbar-child-description' for %s" 367 (error "You must implement `eieio-speedbar-child-description' for %s"
368 (eieio-object-name obj))) 368 (eieio-object-name obj)))
@@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at."
412 412
413;;; Methods to the eieio-speedbar-* classes which need to be overridden. 413;;; Methods to the eieio-speedbar-* classes which need to be overridden.
414;; 414;;
415(defmethod eieio-speedbar-object-children ((_object eieio-speedbar)) 415(cl-defmethod eieio-speedbar-object-children ((_object eieio-speedbar))
416 "Return a list of children to be displayed in speedbar. 416 "Return a list of children to be displayed in speedbar.
417If the return value is a list of OBJECTs, then those objects are 417If the return value is a list of OBJECTs, then those objects are
418queried for details. If the return list is made of strings, 418queried for details. If the return list is made of strings,
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index b64eba1de1f..7672d7f0b6e 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -179,36 +179,31 @@ and reference them using the function `class-option'."
179 ;; of the specified name, and also performs a `defsetf' if applicable 179 ;; of the specified name, and also performs a `defsetf' if applicable
180 ;; so that users can `setf' the space returned by this function. 180 ;; so that users can `setf' the space returned by this function.
181 (when acces 181 (when acces
182 ;; FIXME: The defmethod below only defines a part of the generic 182 (push `(cl-defmethod (setf ,acces) (value (this ,name))
183 ;; function (good), but the define-setter below affects the whole 183 (eieio-oset this ',sname value))
184 ;; generic function (bad)!
185 (push `(gv-define-setter ,acces (store object)
186 ;; Apparently, eieio-oset-default doesn't work like
187 ;; oref-default and only accept class arguments!
188 (list ',(if nil ;; (eq alloc :class)
189 'eieio-oset-default
190 'eieio-oset)
191 object '',sname store))
192 accessors) 184 accessors)
193 (push `(defmethod ,acces ,(if (eq alloc :class) :static :primary) 185 (push `(cl-defmethod ,acces ((this ,name))
194 ((this ,name))
195 ,(format 186 ,(format
196 "Retrieve the slot `%S' from an object of class `%S'." 187 "Retrieve the slot `%S' from an object of class `%S'."
197 sname name) 188 sname name)
198 (if (slot-boundp this ',sname) 189 ;; FIXME: Why is this different from the :reader case?
199 ;; Use oref-default for :class allocated slots, since 190 (if (slot-boundp this ',sname) (eieio-oref this ',sname)))
200 ;; these also accept the use of a class argument instead 191 accessors)
201 ;; of an object argument. 192 (when (and eieio-backward-compatibility (eq alloc :class))
202 (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref) 193 ;; FIXME: How could I declare this *method* as obsolete.
203 this ',sname) 194 (push `(cl-defmethod ,acces ((this (subclass ,name)))
204 ;; Else - Some error? nil? 195 ,(format
205 nil)) 196 "Retrieve the class slot `%S' from a class `%S'.
206 accessors)) 197This method is obsolete."
198 sname name)
199 (if (slot-boundp this ',sname)
200 (eieio-oref-default this ',sname)))
201 accessors)))
207 202
208 ;; If a writer is defined, then create a generic method of that 203 ;; If a writer is defined, then create a generic method of that
209 ;; name whose purpose is to set the value of the slot. 204 ;; name whose purpose is to set the value of the slot.
210 (if writer 205 (if writer
211 (push `(defmethod ,writer ((this ,name) value) 206 (push `(cl-defmethod ,writer ((this ,name) value)
212 ,(format "Set the slot `%S' of an object of class `%S'." 207 ,(format "Set the slot `%S' of an object of class `%S'."
213 sname name) 208 sname name)
214 (setf (slot-value this ',sname) value)) 209 (setf (slot-value this ',sname) value))
@@ -216,7 +211,7 @@ and reference them using the function `class-option'."
216 ;; If a reader is defined, then create a generic method 211 ;; If a reader is defined, then create a generic method
217 ;; of that name whose purpose is to access this slot value. 212 ;; of that name whose purpose is to access this slot value.
218 (if reader 213 (if reader
219 (push `(defmethod ,reader ((this ,name)) 214 (push `(cl-defmethod ,reader ((this ,name))
220 ,(format "Access the slot `%S' from object of class `%S'." 215 ,(format "Access the slot `%S' from object of class `%S'."
221 sname name) 216 sname name)
222 (slot-value this ',sname)) 217 (slot-value this ',sname))
@@ -372,6 +367,10 @@ variable name of the same name as the slot."
372(define-obsolete-function-alias 367(define-obsolete-function-alias
373 'object-class-fast #'eieio--object-class-name "24.4") 368 'object-class-fast #'eieio--object-class-name "24.4")
374 369
370(cl-defgeneric eieio-object-name-string (obj)
371 "Return a string which is OBJ's name."
372 (declare (obsolete eieio-named "25.1")))
373
375(defun eieio-object-name (obj &optional extra) 374(defun eieio-object-name (obj &optional extra)
376 "Return a Lisp like symbol string for object OBJ. 375 "Return a Lisp like symbol string for object OBJ.
377If EXTRA, include that in the string returned to represent the symbol." 376If EXTRA, include that in the string returned to represent the symbol."
@@ -386,15 +385,13 @@ If EXTRA, include that in the string returned to represent the symbol."
386;; below "for free". Since this field is very rarely used, we got rid of it 385;; below "for free". Since this field is very rarely used, we got rid of it
387;; and instead we keep it in a weak hash-tables, for those very rare objects 386;; and instead we keep it in a weak hash-tables, for those very rare objects
388;; that use it. 387;; that use it.
389(defmethod eieio-object-name-string (obj) 388(cl-defmethod eieio-object-name-string (obj)
390 "Return a string which is OBJ's name."
391 (declare (obsolete eieio-named "25.1"))
392 (or (gethash obj eieio--object-names) 389 (or (gethash obj eieio--object-names)
393 (symbol-name (eieio-object-class obj)))) 390 (symbol-name (eieio-object-class obj))))
394(define-obsolete-function-alias 391(define-obsolete-function-alias
395 'object-name-string #'eieio-object-name-string "24.4") 392 'object-name-string #'eieio-object-name-string "24.4")
396 393
397(defmethod eieio-object-set-name-string (obj name) 394(cl-defmethod eieio-object-set-name-string (obj name)
398 "Set the string which is OBJ's NAME." 395 "Set the string which is OBJ's NAME."
399 (declare (obsolete eieio-named "25.1")) 396 (declare (obsolete eieio-named "25.1"))
400 (eieio--check-type stringp name) 397 (eieio--check-type stringp name)
@@ -648,13 +645,13 @@ This class is not stored in the `parent' slot of a class vector."
648 645
649(defalias 'standard-class 'eieio-default-superclass) 646(defalias 'standard-class 'eieio-default-superclass)
650 647
651(defgeneric eieio-constructor (class &rest slots) 648(cl-defgeneric eieio-constructor (class &rest slots)
652 "Default constructor for CLASS `eieio-default-superclass'.") 649 "Default constructor for CLASS `eieio-default-superclass'.")
653 650
654(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") 651(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
655 652
656(defmethod eieio-constructor :static 653(cl-defmethod eieio-constructor
657 ((class eieio-default-superclass) &rest slots) 654 ((class (subclass eieio-default-superclass)) &rest slots)
658 "Default constructor for CLASS `eieio-default-superclass'. 655 "Default constructor for CLASS `eieio-default-superclass'.
659SLOTS are the initialization slots used by `shared-initialize'. 656SLOTS are the initialization slots used by `shared-initialize'.
660This static method is called when an object is constructed. 657This static method is called when an object is constructed.
@@ -674,11 +671,11 @@ calls `shared-initialize' on that object."
674 ;; Return the created object. 671 ;; Return the created object.
675 new-object)) 672 new-object))
676 673
677(defgeneric shared-initialize (obj slots) 674(cl-defgeneric shared-initialize (obj slots)
678 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 675 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
679Called from the constructor routine.") 676Called from the constructor routine.")
680 677
681(defmethod shared-initialize ((obj eieio-default-superclass) slots) 678(cl-defmethod shared-initialize ((obj eieio-default-superclass) slots)
682 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 679 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
683Called from the constructor routine." 680Called from the constructor routine."
684 (while slots 681 (while slots
@@ -689,10 +686,10 @@ Called from the constructor routine."
689 (eieio-oset obj rn (car (cdr slots))))) 686 (eieio-oset obj rn (car (cdr slots)))))
690 (setq slots (cdr (cdr slots))))) 687 (setq slots (cdr (cdr slots)))))
691 688
692(defgeneric initialize-instance (this &optional slots) 689(cl-defgeneric initialize-instance (this &optional slots)
693 "Construct the new object THIS based on SLOTS.") 690 "Construct the new object THIS based on SLOTS.")
694 691
695(defmethod initialize-instance ((this eieio-default-superclass) 692(cl-defmethod initialize-instance ((this eieio-default-superclass)
696 &optional slots) 693 &optional slots)
697 "Construct the new object THIS based on SLOTS. 694 "Construct the new object THIS based on SLOTS.
698SLOTS is a tagged list where odd numbered elements are tags, and 695SLOTS is a tagged list where odd numbered elements are tags, and
@@ -724,10 +721,10 @@ dynamically set from SLOTS."
724 ;; Shared initialize will parse our slots for us. 721 ;; Shared initialize will parse our slots for us.
725 (shared-initialize this slots)) 722 (shared-initialize this slots))
726 723
727(defgeneric slot-missing (object slot-name operation &optional new-value) 724(cl-defgeneric slot-missing (object slot-name operation &optional new-value)
728 "Method invoked when an attempt to access a slot in OBJECT fails.") 725 "Method invoked when an attempt to access a slot in OBJECT fails.")
729 726
730(defmethod slot-missing ((object eieio-default-superclass) slot-name 727(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name
731 _operation &optional _new-value) 728 _operation &optional _new-value)
732 "Method invoked when an attempt to access a slot in OBJECT fails. 729 "Method invoked when an attempt to access a slot in OBJECT fails.
733SLOT-NAME is the name of the failed slot, OPERATION is the type of access 730SLOT-NAME is the name of the failed slot, OPERATION is the type of access
@@ -739,10 +736,10 @@ directly reference slots in EIEIO objects."
739 (signal 'invalid-slot-name (list (eieio-object-name object) 736 (signal 'invalid-slot-name (list (eieio-object-name object)
740 slot-name))) 737 slot-name)))
741 738
742(defgeneric slot-unbound (object class slot-name fn) 739(cl-defgeneric slot-unbound (object class slot-name fn)
743 "Slot unbound is invoked during an attempt to reference an unbound slot.") 740 "Slot unbound is invoked during an attempt to reference an unbound slot.")
744 741
745(defmethod slot-unbound ((object eieio-default-superclass) 742(cl-defmethod slot-unbound ((object eieio-default-superclass)
746 class slot-name fn) 743 class slot-name fn)
747 "Slot unbound is invoked during an attempt to reference an unbound slot. 744 "Slot unbound is invoked during an attempt to reference an unbound slot.
748OBJECT is the instance of the object being reference. CLASS is the 745OBJECT is the instance of the object being reference. CLASS is the
@@ -757,14 +754,14 @@ EIEIO can only dispatch on the first argument, so the first two are swapped."
757 (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) 754 (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object)
758 slot-name fn))) 755 slot-name fn)))
759 756
760(defgeneric clone (obj &rest params) 757(cl-defgeneric clone (obj &rest params)
761 "Make a copy of OBJ, and then supply PARAMS. 758 "Make a copy of OBJ, and then supply PARAMS.
762PARAMS is a parameter list of the same form used by `initialize-instance'. 759PARAMS is a parameter list of the same form used by `initialize-instance'.
763 760
764When overloading `clone', be sure to call `call-next-method' 761When overloading `clone', be sure to call `call-next-method'
765first and modify the returned object.") 762first and modify the returned object.")
766 763
767(defmethod clone ((obj eieio-default-superclass) &rest params) 764(cl-defmethod clone ((obj eieio-default-superclass) &rest params)
768 "Make a copy of OBJ, and then apply PARAMS." 765 "Make a copy of OBJ, and then apply PARAMS."
769 (let ((nobj (copy-sequence obj))) 766 (let ((nobj (copy-sequence obj)))
770 (if (stringp (car params)) 767 (if (stringp (car params))
@@ -773,24 +770,24 @@ first and modify the returned object.")
773 (if params (shared-initialize nobj params)) 770 (if params (shared-initialize nobj params))
774 nobj)) 771 nobj))
775 772
776(defgeneric destructor (this &rest params) 773(cl-defgeneric destructor (this &rest params)
777 "Destructor for cleaning up any dynamic links to our object.") 774 "Destructor for cleaning up any dynamic links to our object.")
778 775
779(defmethod destructor ((_this eieio-default-superclass) &rest _params) 776(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params)
780 "Destructor for cleaning up any dynamic links to our object. 777 "Destructor for cleaning up any dynamic links to our object.
781Argument THIS is the object being destroyed. PARAMS are additional 778Argument THIS is the object being destroyed. PARAMS are additional
782ignored parameters." 779ignored parameters."
783 ;; No cleanup... yet. 780 ;; No cleanup... yet.
784 ) 781 )
785 782
786(defgeneric object-print (this &rest strings) 783(cl-defgeneric object-print (this &rest strings)
787 "Pretty printer for object THIS. Call function `object-name' with STRINGS. 784 "Pretty printer for object THIS. Call function `object-name' with STRINGS.
788 785
789It is sometimes useful to put a summary of the object into the 786It is sometimes useful to put a summary of the object into the
790default #<notation> string when using EIEIO browsing tools. 787default #<notation> string when using EIEIO browsing tools.
791Implement this method to customize the summary.") 788Implement this method to customize the summary.")
792 789
793(defmethod object-print ((this eieio-default-superclass) &rest strings) 790(cl-defmethod object-print ((this eieio-default-superclass) &rest strings)
794 "Pretty printer for object THIS. Call function `object-name' with STRINGS. 791 "Pretty printer for object THIS. Call function `object-name' with STRINGS.
795The default method for printing object THIS is to use the 792The default method for printing object THIS is to use the
796function `object-name'. 793function `object-name'.
@@ -807,11 +804,11 @@ to prepend a space."
807(defvar eieio-print-depth 0 804(defvar eieio-print-depth 0
808 "When printing, keep track of the current indentation depth.") 805 "When printing, keep track of the current indentation depth.")
809 806
810(defgeneric object-write (this &optional comment) 807(cl-defgeneric object-write (this &optional comment)
811 "Write out object THIS to the current stream. 808 "Write out object THIS to the current stream.
812Optional COMMENT will add comments to the beginning of the output.") 809Optional COMMENT will add comments to the beginning of the output.")
813 810
814(defmethod object-write ((this eieio-default-superclass) &optional comment) 811(cl-defmethod object-write ((this eieio-default-superclass) &optional comment)
815 "Write object THIS out to the current stream. 812 "Write object THIS out to the current stream.
816This writes out the vector version of this object. Complex and recursive 813This writes out the vector version of this object. Complex and recursive
817object are discouraged from being written. 814object are discouraged from being written.
diff --git a/test/ChangeLog b/test/ChangeLog
index dcce0bf3c39..d63a561953d 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,7 +1,12 @@
12015-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/cl-generic-tests.el (setf cl--generic-2): Make sure
4 the setf can be used already in the body of the method.
5
12015-01-20 Jorgen Schaefer <contact@jorgenschaefer.de> 62015-01-20 Jorgen Schaefer <contact@jorgenschaefer.de>
2 7
3 * automated/package-test.el (package-test-install-prioritized): 8 * automated/package-test.el (package-test-install-prioritized):
4 Removed test due to unreproducable failures. 9 Remove test due to unreproducable failures.
5 10
62015-01-20 Michal Nazarewicz <mina86@mina86.com> 112015-01-20 Michal Nazarewicz <mina86@mina86.com>
7 12
@@ -15,8 +20,8 @@
15 A new helper function for testing `tildify-double-space-undos' 20 A new helper function for testing `tildify-double-space-undos'
16 behaviour in the `tildify-space' function. 21 behaviour in the `tildify-space' function.
17 (tildify-space-undo-test-html, tildify-space-undo-test-html-nbsp) 22 (tildify-space-undo-test-html, tildify-space-undo-test-html-nbsp)
18 (tildify-space-undo-test-xml, tildify-space-undo-test-tex): New 23 (tildify-space-undo-test-xml, tildify-space-undo-test-tex):
19 tests for `tildify-doule-space-undos' behaviour. 24 New tests for `tildify-doule-space-undos' behaviour.
20 25
21 * automated/tildify-tests.el (tildify-space-test--test): 26 * automated/tildify-tests.el (tildify-space-test--test):
22 A new helper function for testing `tildify-space' function. 27 A new helper function for testing `tildify-space' function.
diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el
index 1c01d9b164b..bc9a1ece423 100644
--- a/test/automated/cl-generic-tests.el
+++ b/test/automated/cl-generic-tests.el
@@ -73,6 +73,11 @@
73 (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) 73 (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
74 '("child11" "around""child1" "parent" a)))) 74 '("child11" "around""child1" "parent" a))))
75 75
76;; I don't know how to put this inside an `ert-test'. This tests that `setf'
77;; can be used directly inside the body of the setf method.
78(cl-defmethod (setf cl--generic-2) (v (y integer) z)
79 (setf (cl--generic-2 (nth y z) z) v))
80
76(ert-deftest cl-generic-test-03-setf () 81(ert-deftest cl-generic-test-03-setf ()
77 (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) 82 (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
78 (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) 83 (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el
index 3918fb904fe..da5f59a4654 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -292,6 +292,7 @@
292 292
293(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) 293(defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
294 ;(message "+Ja") 294 ;(message "+Ja")
295 ;; FIXME: Using next-method-p in an after-method is invalid!
295 (when (next-method-p) 296 (when (next-method-p)
296 (call-next-method)) 297 (call-next-method))
297 ;(message "-Ja") 298 ;(message "-Ja")
@@ -302,6 +303,7 @@
302 303
303(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) 304(defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
304 ;(message "+Jb") 305 ;(message "+Jb")
306 ;; FIXME: Using next-method-p in an after-method is invalid!
305 (when (next-method-p) 307 (when (next-method-p)
306 (call-next-method)) 308 (call-next-method))
307 ;(message "-Jb") 309 ;(message "-Jb")