Commit 59e7fe6d authored by Stefan Monnier's avatar Stefan Monnier

* 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.
parent 41efcf4d
2015-01-21 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el: Use cl-defmethod.
(defclass): Generate cl-defmethod calls; use setf methods for :accessor.
(eieio-object-name-string): Declare as obsolete.
* 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.
* emacs-lisp/eieio-compat.el (eieio--defmethod): Avoid no-next-method
errors when there's a `before' but no `primary' (bug#19645).
(next-method-p): Return nil rather than signal an error.
(eieio-defgeneric): Remove bogus (fboundp 'method).
* emacs-lisp/eieio-speedbar.el:
* emacs-lisp/eieio-datadebug.el:
* emacs-lisp/eieio-custom.el:
* emacs-lisp/eieio-base.el: Use cl-defmethod.
* 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.
2015-01-21 Dmitry Gutov <dgutov@yandex.ru>
* progmodes/xref.el (xref--xref-buffer-mode-map): Define before
......
......@@ -98,19 +98,20 @@ They should be sorted from most specific to least specific.")
(:constructor cl--generic-make
(name &optional dispatches method-table))
(:predicate nil))
(name nil :read-only t) ;Pointer back to the symbol.
(name nil :type symbol :read-only t) ;Pointer back to the symbol.
;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
;; where the EXPs are expressions (to be `or'd together) to compute the tag
;; on which to dispatch and PRIORITY is the priority of each expression to
;; decide in which order to sort them.
;; The most important dispatch is last in the list (and the least is first).
dispatches
(dispatches nil :type (list-of (cons natnum (list-of tagcode))))
;; `method-table' is a list of
;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
;; (and hence expects an extra argument holding the next-method).
method-table)
(method-table nil :type (list-of (cons (cons (list-of type) keyword)
(cons boolean function)))))
(defmacro cl--generic (name)
`(get ,name 'cl--generic))
......@@ -134,15 +135,16 @@ They should be sorted from most specific to least specific.")
generic))
(defun cl--generic-setf-rewrite (name)
(let ((setter (intern (format "cl-generic-setter--%s" name))))
(cons setter
`(eval-and-compile
(unless (eq ',setter (get ',name 'cl-generic-setter))
;; (when (get ',name 'gv-expander)
;; (error "gv-expander conflicts with (setf %S)" ',name))
(setf (get ',name 'cl-generic-setter) ',setter)
(gv-define-setter ,name (val &rest args)
(cons ',setter (cons val args))))))))
(let* ((setter (intern (format "cl-generic-setter--%s" name)))
(exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
;; (when (get ',name 'gv-expander)
;; (error "gv-expander conflicts with (setf %S)" ',name))
(setf (get ',name 'cl-generic-setter) ',setter)
(gv-define-setter ,name (val &rest args)
(cons ',setter (cons val args))))))
;; Make sure `setf' can be used right away, e.g. in the body of the method.
(eval exp t)
(cons setter exp)))
;;;###autoload
(defmacro cl-defgeneric (name args &rest options-and-methods)
......@@ -151,8 +153,9 @@ DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
is appropriate to use. Specific methods are defined with `cl-defmethod'.
With this implementation the ARGS are currently ignored.
OPTIONS-AND-METHODS is currently only used to specify the docstring,
via (:documentation DOCSTRING)."
OPTIONS-AND-METHODS currently understands:
- (:documentation DOCSTRING)
- (declare DECLARATIONS)"
(declare (indent 2) (doc-string 3))
(let* ((docprop (assq :documentation options-and-methods))
(doc (cond ((stringp (car-safe options-and-methods))
......@@ -161,13 +164,26 @@ via (:documentation DOCSTRING)."
(prog1
(cadr docprop)
(setq options-and-methods
(delq docprop options-and-methods)))))))
(delq docprop options-and-methods))))))
(declarations (assq 'declare options-and-methods)))
(when declarations
(setq options-and-methods
(delq declarations options-and-methods)))
`(progn
,(when (eq 'setf (car-safe name))
(pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
(cadr name))))
(setq name setter)
code))
,@(mapcar (lambda (declaration)
(let ((f (cdr (assq (car declaration)
defun-declarations-alist))))
(cond
(f (apply (car f) name args (cdr declaration)))
(t (message "Warning: Unknown defun property `%S' in %S"
(car declaration) name)
nil))))
(cdr declarations))
(defalias ',name
(cl-generic-define ',name ',args ',options-and-methods)
,(help-add-fundoc-usage doc args)))))
......@@ -292,18 +308,19 @@ which case this method will be invoked when the argument is `eql' to VAL.
list ; arguments
[ &optional stringp ] ; documentation string
def-body))) ; part to be debugged
(let ((qualifiers nil))
(let ((qualifiers nil)
(setfizer (if (eq 'setf (car-safe name))
;; Call it before we call cl--generic-lambda.
(cl--generic-setf-rewrite (cadr name)))))
(while (keywordp args)
(push args qualifiers)
(setq args (pop body)))
(pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
(`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
`(progn
,(when (eq 'setf (car-safe name))
(pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
(cadr name))))
(setq name setter)
code))
,(when setfizer
(setq name (car setfizer))
(cdr setfizer))
,(and (get name 'byte-obsolete-info)
(or (not (fboundp 'byte-compile-warning-enabled-p))
(byte-compile-warning-enabled-p 'obsolete))
......@@ -311,6 +328,11 @@ which case this method will be invoked when the argument is `eql' to VAL.
(macroexp--warn-and-return
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the
;; function, so warnings like "not known to be defined" are fair game.
;; But in practice, it's common to use `cl-defmethod'
;; without a previous `cl-defgeneric'.
(declare-function ,name "")
(cl-generic-define-method ',name ',qualifiers ',args
,uses-cnm ,fun)))))
......@@ -344,14 +366,14 @@ which case this method will be invoked when the argument is `eql' to VAL.
(if me (setcdr me (cons uses-cnm function))
(setf (cl--generic-method-table generic)
(cons `(,key ,uses-cnm . ,function) mt)))
;; For aliases, cl--generic-name gives us the actual name.
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)
(let ((gfun (cl--generic-make-function generic))
;; Prevent `defalias' from recording this as the definition site of
;; the generic function.
current-load-list)
(defalias (cl--generic-name generic) gfun))
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)))
;; For aliases, cl--generic-name gives us the actual name.
(defalias (cl--generic-name generic) gfun))))
(defmacro cl--generic-with-memoization (place &rest code)
(declare (indent 1) (debug t))
......@@ -448,8 +470,12 @@ for all those different tags in the method-cache.")
;; We don't currently have "method objects" like CLOS
;; does so we can't really do it the CLOS way.
;; The closest would be to pass the lambda corresponding
;; to the method, but the caller wouldn't be able to do
;; much with it anyway. So we pass nil for now.
;; to the method, or maybe the ((SPECIALIZERS
;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method
;; table, but the caller wouldn't be able to do much with
;; it anyway. So we pass nil for now.
;; FIXME: signal `no-primary-method' if there's
;; no primary.
(apply #'cl-no-next-method generic-name nil args)))
;; We use `cdr' to drop the `uses-cnm' annotations.
(before
......@@ -566,6 +592,24 @@ Can only be used from within the lexical body of a primary or around method."
(add-to-list 'find-function-regexp-alist
`(cl-defmethod . ,#'cl--generic-search-method)))
(defun cl--generic-method-info (method)
(pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method))
(let* ((args (help-function-arglist function 'names))
(docstring (documentation function))
(doconly (if docstring
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring))))
(combined-args ()))
(if uses-cnm (setq args (cdr args)))
(dolist (specializer specializers)
(let ((arg (if (eq '&rest (car args))
(intern (format "arg%d" (length combined-args)))
(pop args))))
(push (if (eq specializer t) arg (list arg specializer))
combined-args)))
(setq combined-args (append (nreverse combined-args) args))
(list qualifier combined-args doconly))))
(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
(defun cl--generic-describe (function)
(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."
(insert "\n\nThis is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
(pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method)
(cl--generic-method-table generic))
(let* ((args (help-function-arglist method 'names))
(docstring (documentation method))
(doconly (if docstring
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring))))
(combined-args ()))
(if uses-cnm (setq args (cdr args)))
(dolist (specializer specializers)
(let ((arg (if (eq '&rest (car args))
(intern (format "arg%d" (length combined-args)))
(pop args))))
(push (if (eq specializer t) arg (list arg specializer))
combined-args)))
(setq combined-args (append (nreverse combined-args) args))
(dolist (method (cl--generic-method-table generic))
(let* ((info (cl--generic-method-info method)))
;; FIXME: Add hyperlinks for the types as well.
(insert (format "%S %S" qualifier combined-args))
(let* ((met-name (cons function specializers))
(insert (format "%S %S" (nth 0 info) (nth 1 info)))
(let* ((met-name (cons function (caar method)))
(file (find-lisp-object-file-name met-name 'cl-defmethod)))
(when file
(insert " in `")
......@@ -601,7 +631,7 @@ Can only be used from within the lexical body of a primary or around method."
'help-function-def met-name file
'cl-defmethod)
(insert "'.\n")))
(insert "\n" (or doconly "Undocumented") "\n\n")))))))
(insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
;;; Support for (eql <val>) specializers.
......
......@@ -52,7 +52,7 @@ a parent instance. When a slot in the child is referenced, and has
not been set, use values from the parent."
:abstract t)
(defmethod slot-unbound ((object eieio-instance-inheritor)
(cl-defmethod slot-unbound ((object eieio-instance-inheritor)
_class slot-name _fn)
"If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
SLOT-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."
;; method if the parent instance's slot is unbound.
(eieio-oref (oref object parent-instance) slot-name)
;; Throw the regular signal.
(call-next-method)))
(cl-call-next-method)))
(defmethod clone ((obj eieio-instance-inheritor) &rest _params)
(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params)
"Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS."
(let ((nobj (call-next-method)))
(let ((nobj (cl-call-next-method)))
(oset nobj parent-instance obj)
nobj))
(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
slot)
"Return non-nil if the instance inheritor OBJECT's SLOT is bound.
See `slot-boundp' for details on binding slots.
......@@ -103,7 +103,7 @@ Inheritors from this class must overload `tracking-symbol' which is
a variable symbol used to store a list of all instances."
:abstract t)
(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
(cl-defmethod initialize-instance :after ((this eieio-instance-tracker)
&rest _slots)
"Make sure THIS is in our master list of this class.
Optional argument SLOTS are the initialization arguments."
......@@ -112,7 +112,7 @@ Optional argument SLOTS are the initialization arguments."
(if (not (memq this (symbol-value sym)))
(set sym (append (symbol-value sym) (list this))))))
(defmethod delete-instance ((this eieio-instance-tracker))
(cl-defmethod delete-instance ((this eieio-instance-tracker))
"Remove THIS from the master list of this class."
(set (oref this tracking-symbol)
(delq this (symbol-value (oref this tracking-symbol)))))
......@@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
A singleton is a class which will only ever have one instance."
:abstract t)
(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots)
(cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots)
"Constructor for singleton CLASS.
NAME and SLOTS initialize the new object.
This constructor guarantees that no matter how many you request,
......@@ -149,7 +149,7 @@ only one object ever exists."
;; with class allocated slots or default values.
(let ((old (oref-default class singleton)))
(if (eq old eieio-unbound)
(oset-default class singleton (call-next-method))
(oset-default class singleton (cl-call-next-method))
old)))
......@@ -198,7 +198,7 @@ object. For this reason, only slots which do not have an `:initarg'
specified will not be saved."
:abstract t)
(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
&optional name)
"Prepare to save THIS. Use in an `interactive' statement.
Query 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."
;; No match, not a class.
nil)))
(defmethod object-write ((this eieio-persistent) &optional comment)
(cl-defmethod object-write ((this eieio-persistent) &optional comment)
"Write persistent object THIS out to the current stream.
Optional argument COMMENT is a header line comment."
(call-next-method this (or comment (oref this file-header-line))))
(cl-call-next-method this (or comment (oref this file-header-line))))
(defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
"For object THIS, make absolute file name FILE relative."
(file-relative-name (expand-file-name file)
(file-name-directory (oref this file))))
(defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
"Save persistent object THIS to disk.
Optional argument FILE overrides the file name specified in the object
instance."
......@@ -474,21 +474,21 @@ instance."
"Object with a name."
:abstract t)
(defmethod eieio-object-name-string ((obj eieio-named))
(cl-defmethod eieio-object-name-string ((obj eieio-named))
"Return a string which is OBJ's name."
(or (slot-value obj 'object-name)
(symbol-name (eieio-object-class obj))))
(defmethod eieio-object-set-name-string ((obj eieio-named) name)
(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
"Set the string which is OBJ's NAME."
(eieio--check-type stringp name)
(eieio-oset obj 'object-name name))
(defmethod clone ((obj eieio-named) &rest params)
(cl-defmethod clone ((obj eieio-named) &rest params)
"Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS."
(let* ((newname (and (stringp (car params)) (pop params)))
(nobj (apply #'call-next-method obj params))
(nobj (apply #'cl-call-next-method obj params))
(nm (slot-value obj 'object-name)))
(eieio-oset obj 'object-name
(or newname
......
......@@ -190,13 +190,27 @@ Summary:
(if split (cdr split) docstring))))
(new-docstring (help-add-fundoc-usage doc-only
(cons 'cl-cnm args))))
;; FIXME: ¡Add the new-docstring to those closures!
;; FIXME: ¡Add new-docstring to those closures!
(lambda (cnm &rest args)
(cl-letf (((symbol-function 'call-next-method) cnm)
((symbol-function 'next-method-p)
(lambda () (cl--generic-isnot-nnm-p cnm))))
(apply code args))))
code))))
code))
;; The old EIEIO code did not signal an error when there are methods
;; applicable but only of the before/after kind. So if we add a :before
;; or :after, make sure there's a matching dummy primary.
(when (and (memq kind '(:before :after))
(not (assoc (cons (mapcar (lambda (arg)
(if (consp arg) (nth 1 arg) t))
specializers)
:primary)
(cl--generic-method-table (cl--generic method)))))
(cl-generic-define-method method () specializers t
(lambda (cnm &rest args)
(if (cl--generic-isnot-nnm-p cnm)
(apply cnm args)))))
method))
;; Compatibility with code which tries to catch `no-method-definition' errors.
(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
......@@ -212,7 +226,12 @@ Summary:
(apply #'cl-no-applicable-method method object args))
(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
(define-obsolete-function-alias 'next-method-p 'cl-next-method-p "25.1")
(defun next-method-p ()
(declare (obsolete cl-next-method-p "25.1"))
;; EIEIO's `next-method-p' just returned nil when called in an
;; invalid context.
(message "next-method-p called outside of a primary or around method")
nil)
;;;###autoload
(defun eieio-defmethod (method args)
......@@ -225,11 +244,9 @@ Summary:
(defun eieio-defgeneric (method doc-string)
"Obsolete work part of an old version of the `defgeneric' macro."
(declare (obsolete cl-defgeneric "24.1"))
;; Don't do this over and over.
(unless (fboundp 'method)
(eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
;; Return the method
'method))
(eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
;; Return the method
'method)
;;;###autoload
(defun eieio-defclass (cname superclasses slots options)
......
......@@ -322,7 +322,7 @@ Optional argument IGNORE is an extraneous parameter."
;; This is the same object we had before.
obj))
(defmethod eieio-done-customizing ((_obj eieio-default-superclass))
(cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass))
"When applying change to a widget, call this method.
This method is called by the default widget-edit commands.
User 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."
"Major mode for customizing EIEIO objects.
\\{eieio-custom-mode-map}")
(defmethod eieio-customize-object ((obj eieio-default-superclass)
(cl-defmethod eieio-customize-object ((obj eieio-default-superclass)
&optional group)
"Customize OBJ in a specialized custom buffer.
To override call the `eieio-custom-widget-insert' to just insert the
......@@ -386,7 +386,7 @@ These groups are specified with the `:group' slot flag."
(make-local-variable 'eieio-cog)
(setq eieio-cog g)))
(defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
"Insert an Apply and Reset button into the object editor.
Argument OBJ is the object being customized."
(widget-create 'push-button
......@@ -417,7 +417,7 @@ Argument OBJ is the object being customized."
(bury-buffer))
"Cancel"))
(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
(cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
&rest flags)
"Insert the widget used for editing object OBJ in the current buffer.
Arguments FLAGS are widget compatible flags.
......@@ -446,7 +446,7 @@ Must return the created widget."
;; These functions provide the ability to create dynamic menus to
;; customize specific sections of an object. They do not hook directly
;; into a filter, but can be used to create easymenu vectors.
(defmethod eieio-customize-object-group ((obj eieio-default-superclass))
(cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass))
"Create a list of vectors for customizing sections of OBJ."
(mapcar (lambda (group)
(vector (concat "Group " (symbol-name group))
......@@ -457,7 +457,7 @@ Must return the created widget."
(defvar eieio-read-custom-group-history nil
"History for the custom group reader.")
(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass))
"Do a completing read on the name of a customization group in OBJ.
Return the symbol for the group, or nil"
(let ((g (eieio--class-option (eieio--object-class-object obj)
......
......@@ -79,7 +79,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
;;
;; Each object should have an opportunity to show stuff about itself.
(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
prefix)
"Insert the slots of OBJ into the current DDEBUG buffer."
(let ((inhibit-read-only t))
......@@ -124,7 +124,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
;;
;; A generic function to run DDEBUG on an object and popup a new buffer.
;;
(defmethod data-debug-show ((obj eieio-default-superclass))
(cl-defmethod data-debug-show ((obj eieio-default-superclass))
"Run ddebug against any EIEIO object OBJ."
(data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
(data-debug-insert-object-slots obj "]"))
......
......@@ -122,29 +122,18 @@ If CLASS is actually an object, then also display current values of that object.
;; Describe all the slots in this class.
(eieio-help-class-slots class)
;; Describe all the methods specific to this class.
(let ((methods (eieio-all-generic-functions class))
(type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"])
counter doc)
(when methods
(let ((generics (eieio-all-generic-functions class)))
(when generics
(insert (propertize "Specialized Methods:\n\n" 'face 'bold))
(while methods
(setq doc (eieio-method-documentation (car methods) class))
(insert "`")
(help-insert-xref-button (symbol-name (car methods))
'help-function (car methods))
(insert "'")
(if (not doc)
(insert " Undocumented")
(setq counter 0)
(dolist (cur doc)
(when cur
(insert " " (aref type counter) " "
(prin1-to-string (car cur) (current-buffer))
"\n"
(or (cdr cur) "")))
(setq counter (1+ counter))))
(insert "\n\n")
(setq methods (cdr methods))))))
(dolist (generic generics)
(insert "`")
(help-insert-xref-button (symbol-name generic) 'help-function generic)
(insert "'")
(pcase-dolist (`(,qualifier ,args ,doc)
(eieio-method-documentation generic class))
(insert (format " %S %S\n" qualifier args)
(or doc "")))
(insert "\n\n")))))
(defun eieio-help-class-slots (class)
"Print help description for the slots in CLASS.
......@@ -311,6 +300,20 @@ are not abstract."
(eieio-help-class ctr))
))))
(defun eieio--specializers-apply-to-class-p (specializers class)
"Return non-nil if a method with SPECIALIZERS applies to CLASS."
(let ((applies nil))
(dolist (specializer specializers)
(if (eq 'subclass (car-safe specializer))
(setq specializer (nth 1 specializer)))
;; Don't include the methods that are "too generic", such as those
;; applying to `eieio-default-superclass'.
(and (not (memq specializer '(t eieio-default-superclass)))
(class-p specializer)
(child-of-class-p class specializer)
(setq applies t)))
applies))
(defun eieio-all-generic-functions (&optional class)
"Return a list of all generic functions.
Optional CLASS argument returns only those functions that contain
......@@ -318,53 +321,31 @@ methods for CLASS."
(let ((l nil))
(mapatoms
(lambda (symbol)
(let ((tree (get symbol 'eieio-method-hashtable)))
(when tree
;; A symbol might be interned for that class in one of
;; these three slots in the method-obarray.
(if (or (not class)
(car (gethash class (aref tree 0)))
(car (gethash class (aref tree 1)))
(car (gethash class (aref tree 2))))
(setq l (cons symbol l)))))))
(let ((generic (and (fboundp symbol) (cl--generic symbol))))
(and generic
(catch 'found
(if (null class) (throw 'found t))
(pcase-dolist (`((,specializers . ,_qualifier) . ,_)
(cl--generic-method-table generic))
(if (eieio--specializers-apply-to-class-p
specializers class)
(throw 'found t))))
(push symbol l)))))
l))
(defun eieio-method-documentation (generic class)
"Return a list of the specific documentation of GENERIC for CLASS.
If there is not an explicit method for CLASS in GENERIC, or if that
function has no documentation, then return nil."
(let ((tree (get generic 'eieio-method-hashtable)))
(when tree
;; A symbol might be interned for that class in one of
;; these three slots in the method-hashtable.
;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static,
;; 1 for before, and 2 for primary (and 3 for after)?
(let ((before (car (gethash class (aref tree 0))))
(primary (car (gethash class (aref tree 1))))
(after (car (gethash class (aref tree 2)))))
(if (not (or before primary after))
nil