From 59e7fe6d0c6988687b53c279941c9ebb3f887eed Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 21 Jan 2015 14:39:06 -0500 Subject: [PATCH] * 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. --- lisp/ChangeLog | 33 ++++++++ lisp/emacs-lisp/cl-generic.el | 122 +++++++++++++++++++----------- lisp/emacs-lisp/eieio-base.el | 36 ++++----- lisp/emacs-lisp/eieio-compat.el | 33 ++++++-- lisp/emacs-lisp/eieio-custom.el | 12 +-- lisp/emacs-lisp/eieio-datadebug.el | 4 +- lisp/emacs-lisp/eieio-opt.el | 113 ++++++++++++--------------- lisp/emacs-lisp/eieio-speedbar.el | 20 ++--- lisp/emacs-lisp/eieio.el | 89 +++++++++++----------- test/ChangeLog | 11 ++- test/automated/cl-generic-tests.el | 5 ++ test/automated/eieio-test-methodinvoke.el | 2 + 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 @@ +2015-01-21 Stefan Monnier + + * 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 * 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.") (: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 ) specializers. 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 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 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: (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) 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." ;; 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) 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." ;; ;; 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 "]")) 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. ;; 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 - (list (if before - (cons (help-function-arglist before) - (documentation before)) - nil) - (if primary - (cons (help-function-arglist primary) - (documentation primary)) - nil) - (if after - (cons (help-function-arglist after) - (documentation after)) - nil))))))) - -(defvar eieio-read-generic nil - "History of the `eieio-read-generic' prompt.") - -(defun eieio-read-generic (prompt &optional historyvar) - "Read a generic function from the minibuffer with PROMPT. -Optional argument HISTORYVAR is the variable to use as history." - (intern (completing-read prompt obarray #'generic-p - t nil (or historyvar 'eieio-read-generic)))) + "Return info for all methods of GENERIC applicable to CLASS. +The value returned is a list of elements of the form +\(QUALIFIER ARGS DOC)." + (let ((generic (cl--generic generic)) + (docs ())) + (when generic + (dolist (method (cl--generic-method-table generic)) + (pcase-let ((`((,specializers . ,_qualifier) . ,_) method)) + (when (eieio--specializers-apply-to-class-p + specializers class) + (push (cl--generic-method-info method) docs))))) + docs)) ;;; METHOD STATS ;; 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." ;; when no other methods are found, allowing multiple inheritance to work ;; reliably with eieio-speedbar. -(defmethod eieio-speedbar-description (object) +(cl-defmethod eieio-speedbar-description (object) "Return a string describing OBJECT." (eieio-object-name-string object)) -(defmethod eieio-speedbar-derive-line-path (_object) +(cl-defmethod eieio-speedbar-derive-line-path (_object) "Return the path which OBJECT has something to do with." nil) -(defmethod eieio-speedbar-object-buttonname (object) +(cl-defmethod eieio-speedbar-object-buttonname (object) "Return a string to use as a speedbar button for OBJECT." (eieio-object-name-string object)) -(defmethod eieio-speedbar-make-tag-line (object depth) +(cl-defmethod eieio-speedbar-make-tag-line (object depth) "Insert a tag line into speedbar at point for OBJECT. By default, all objects appear as simple TAGS with no need to inherit from the 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." 'speedbar-tag-face depth)) -(defmethod eieio-speedbar-handle-click (object) +(cl-defmethod eieio-speedbar-handle-click (object) "Handle a click action on OBJECT in speedbar. Any object can be represented as a tag in SPEEDBAR without special attributes. 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." ;;; Methods to eieio-speedbar-* which do not need to be overridden ;; -(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) +(cl-defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) depth) "Insert a tag line into speedbar at point for OBJECT. All 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." (if exp (eieio-speedbar-expand object (1+ depth)))))) -(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth) +(cl-defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth) "Base method for creating tag lines for non-object children." (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" (eieio-object-name object))) -(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) +(cl-defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) "Expand OBJECT at indentation DEPTH. Inserts a list of new tag lines representing expanded elements within OBJECT." @@ -362,7 +362,7 @@ TOKEN is the object. INDENT is the current indentation level." (t (error "Ooops... not sure what to do"))) (speedbar-center-buffer-smartly)) -(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) +(cl-defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) "Return a description for a child of OBJ which is not an object." (error "You must implement `eieio-speedbar-child-description' for %s" (eieio-object-name obj))) @@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at." ;;; Methods to the eieio-speedbar-* classes which need to be overridden. ;; -(defmethod eieio-speedbar-object-children ((_object eieio-speedbar)) +(cl-defmethod eieio-speedbar-object-children ((_object eieio-speedbar)) "Return a list of children to be displayed in speedbar. If the return value is a list of OBJECTs, then those objects are queried 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'." ;; of the specified name, and also performs a `defsetf' if applicable ;; so that users can `setf' the space returned by this function. (when acces - ;; FIXME: The defmethod below only defines a part of the generic - ;; function (good), but the define-setter below affects the whole - ;; generic function (bad)! - (push `(gv-define-setter ,acces (store object) - ;; Apparently, eieio-oset-default doesn't work like - ;; oref-default and only accept class arguments! - (list ',(if nil ;; (eq alloc :class) - 'eieio-oset-default - 'eieio-oset) - object '',sname store)) + (push `(cl-defmethod (setf ,acces) (value (this ,name)) + (eieio-oset this ',sname value)) accessors) - (push `(defmethod ,acces ,(if (eq alloc :class) :static :primary) - ((this ,name)) + (push `(cl-defmethod ,acces ((this ,name)) ,(format "Retrieve the slot `%S' from an object of class `%S'." sname name) - (if (slot-boundp this ',sname) - ;; Use oref-default for :class allocated slots, since - ;; these also accept the use of a class argument instead - ;; of an object argument. - (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref) - this ',sname) - ;; Else - Some error? nil? - nil)) - accessors)) + ;; FIXME: Why is this different from the :reader case? + (if (slot-boundp this ',sname) (eieio-oref this ',sname))) + accessors) + (when (and eieio-backward-compatibility (eq alloc :class)) + ;; FIXME: How could I declare this *method* as obsolete. + (push `(cl-defmethod ,acces ((this (subclass ,name))) + ,(format + "Retrieve the class slot `%S' from a class `%S'. +This method is obsolete." + sname name) + (if (slot-boundp this ',sname) + (eieio-oref-default this ',sname))) + accessors))) ;; If a writer is defined, then create a generic method of that ;; name whose purpose is to set the value of the slot. (if writer - (push `(defmethod ,writer ((this ,name) value) + (push `(cl-defmethod ,writer ((this ,name) value) ,(format "Set the slot `%S' of an object of class `%S'." sname name) (setf (slot-value this ',sname) value)) @@ -216,7 +211,7 @@ and reference them using the function `class-option'." ;; If a reader is defined, then create a generic method ;; of that name whose purpose is to access this slot value. (if reader - (push `(defmethod ,reader ((this ,name)) + (push `(cl-defmethod ,reader ((this ,name)) ,(format "Access the slot `%S' from object of class `%S'." sname name) (slot-value this ',sname)) @@ -372,6 +367,10 @@ variable name of the same name as the slot." (define-obsolete-function-alias 'object-class-fast #'eieio--object-class-name "24.4") +(cl-defgeneric eieio-object-name-string (obj) + "Return a string which is OBJ's name." + (declare (obsolete eieio-named "25.1"))) + (defun eieio-object-name (obj &optional extra) "Return a Lisp like symbol string for object OBJ. If 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." ;; below "for free". Since this field is very rarely used, we got rid of it ;; and instead we keep it in a weak hash-tables, for those very rare objects ;; that use it. -(defmethod eieio-object-name-string (obj) - "Return a string which is OBJ's name." - (declare (obsolete eieio-named "25.1")) +(cl-defmethod eieio-object-name-string (obj) (or (gethash obj eieio--object-names) (symbol-name (eieio-object-class obj)))) (define-obsolete-function-alias 'object-name-string #'eieio-object-name-string "24.4") -(defmethod eieio-object-set-name-string (obj name) +(cl-defmethod eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." (declare (obsolete eieio-named "25.1")) (eieio--check-type stringp name) @@ -648,13 +645,13 @@ This class is not stored in the `parent' slot of a class vector." (defalias 'standard-class 'eieio-default-superclass) -(defgeneric eieio-constructor (class &rest slots) +(cl-defgeneric eieio-constructor (class &rest slots) "Default constructor for CLASS `eieio-default-superclass'.") (define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") -(defmethod eieio-constructor :static - ((class eieio-default-superclass) &rest slots) +(cl-defmethod eieio-constructor + ((class (subclass eieio-default-superclass)) &rest slots) "Default constructor for CLASS `eieio-default-superclass'. SLOTS are the initialization slots used by `shared-initialize'. This static method is called when an object is constructed. @@ -674,11 +671,11 @@ calls `shared-initialize' on that object." ;; Return the created object. new-object)) -(defgeneric shared-initialize (obj slots) +(cl-defgeneric shared-initialize (obj slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine.") -(defmethod shared-initialize ((obj eieio-default-superclass) slots) +(cl-defmethod shared-initialize ((obj eieio-default-superclass) slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine." (while slots @@ -689,10 +686,10 @@ Called from the constructor routine." (eieio-oset obj rn (car (cdr slots))))) (setq slots (cdr (cdr slots))))) -(defgeneric initialize-instance (this &optional slots) +(cl-defgeneric initialize-instance (this &optional slots) "Construct the new object THIS based on SLOTS.") -(defmethod initialize-instance ((this eieio-default-superclass) +(cl-defmethod initialize-instance ((this eieio-default-superclass) &optional slots) "Construct the new object THIS based on SLOTS. SLOTS is a tagged list where odd numbered elements are tags, and @@ -724,10 +721,10 @@ dynamically set from SLOTS." ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) -(defgeneric slot-missing (object slot-name operation &optional new-value) +(cl-defgeneric slot-missing (object slot-name operation &optional new-value) "Method invoked when an attempt to access a slot in OBJECT fails.") -(defmethod slot-missing ((object eieio-default-superclass) slot-name +(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. SLOT-NAME is the name of the failed slot, OPERATION is the type of access @@ -739,10 +736,10 @@ directly reference slots in EIEIO objects." (signal 'invalid-slot-name (list (eieio-object-name object) slot-name))) -(defgeneric slot-unbound (object class slot-name fn) +(cl-defgeneric slot-unbound (object class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot.") -(defmethod slot-unbound ((object eieio-default-superclass) +(cl-defmethod slot-unbound ((object eieio-default-superclass) class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot. OBJECT 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." (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) slot-name fn))) -(defgeneric clone (obj &rest params) +(cl-defgeneric clone (obj &rest params) "Make a copy of OBJ, and then supply PARAMS. PARAMS is a parameter list of the same form used by `initialize-instance'. When overloading `clone', be sure to call `call-next-method' first and modify the returned object.") -(defmethod clone ((obj eieio-default-superclass) &rest params) +(cl-defmethod clone ((obj eieio-default-superclass) &rest params) "Make a copy of OBJ, and then apply PARAMS." (let ((nobj (copy-sequence obj))) (if (stringp (car params)) @@ -773,24 +770,24 @@ first and modify the returned object.") (if params (shared-initialize nobj params)) nobj)) -(defgeneric destructor (this &rest params) +(cl-defgeneric destructor (this &rest params) "Destructor for cleaning up any dynamic links to our object.") -(defmethod destructor ((_this eieio-default-superclass) &rest _params) +(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params) "Destructor for cleaning up any dynamic links to our object. Argument THIS is the object being destroyed. PARAMS are additional ignored parameters." ;; No cleanup... yet. ) -(defgeneric object-print (this &rest strings) +(cl-defgeneric object-print (this &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. It is sometimes useful to put a summary of the object into the default # string when using EIEIO browsing tools. Implement this method to customize the summary.") -(defmethod object-print ((this eieio-default-superclass) &rest strings) +(cl-defmethod object-print ((this eieio-default-superclass) &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. The default method for printing object THIS is to use the function `object-name'. @@ -807,11 +804,11 @@ to prepend a space." (defvar eieio-print-depth 0 "When printing, keep track of the current indentation depth.") -(defgeneric object-write (this &optional comment) +(cl-defgeneric object-write (this &optional comment) "Write out object THIS to the current stream. Optional COMMENT will add comments to the beginning of the output.") -(defmethod object-write ((this eieio-default-superclass) &optional comment) +(cl-defmethod object-write ((this eieio-default-superclass) &optional comment) "Write object THIS out to the current stream. This writes out the vector version of this object. Complex and recursive object 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 @@ +2015-01-21 Stefan Monnier + + * automated/cl-generic-tests.el (setf cl--generic-2): Make sure + the setf can be used already in the body of the method. + 2015-01-20 Jorgen Schaefer * automated/package-test.el (package-test-install-prioritized): - Removed test due to unreproducable failures. + Remove test due to unreproducable failures. 2015-01-20 Michal Nazarewicz @@ -15,8 +20,8 @@ A new helper function for testing `tildify-double-space-undos' behaviour in the `tildify-space' function. (tildify-space-undo-test-html, tildify-space-undo-test-html-nbsp) - (tildify-space-undo-test-xml, tildify-space-undo-test-tex): New - tests for `tildify-doule-space-undos' behaviour. + (tildify-space-undo-test-xml, tildify-space-undo-test-tex): + New tests for `tildify-doule-space-undos' behaviour. * automated/tildify-tests.el (tildify-space-test--test): 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 @@ (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) '("child11" "around""child1" "parent" a)))) +;; I don't know how to put this inside an `ert-test'. This tests that `setf' +;; can be used directly inside the body of the setf method. +(cl-defmethod (setf cl--generic-2) (v (y integer) z) + (setf (cl--generic-2 (nth y z) z) v)) + (ert-deftest cl-generic-test-03-setf () (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) (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 @@ (defmethod initialize-instance :after ((this eitest-Ja) &rest slots) ;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) (call-next-method)) ;(message "-Ja") @@ -302,6 +303,7 @@ (defmethod initialize-instance :after ((this eitest-Jb) &rest slots) ;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) (call-next-method)) ;(message "-Jb") -- 2.11.4.GIT