1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 06:20:43 -08:00

* lisp/emacs-lisp/eieio*.el: Remove "name" field of objects

* lisp/emacs-lisp/eieio-base.el (clone) <eieio-instance-inheritor>:
Use call-next-method.
(eieio-constructor): Rename from `constructor'.
(eieio-persistent-convert-list-to-object): Drop objname.
(eieio-persistent-validate/fix-slot-value): Don't hardcode
eieio--object-num-slots.
(eieio-named): Use a normal slot.
(slot-missing) <eieio-named>: Remove.
(eieio-object-name-string, eieio-object-set-name-string, clone)
<eieio-named>: New methods.

* lisp/emacs-lisp/eieio-core.el (eieio--defalias): Follow aliases.
(eieio--object): Remove `name' field.
(eieio-defclass): Adjust to new convention where constructors don't
take an "object name" any more.
(eieio--defgeneric-init-form, eieio--defmethod): Follow aliases.
(eieio-validate-slot-value, eieio-oset-default)
(eieio-slot-name-index): Don't hardcode eieio--object-num-slots.
(eieio-generic-call-primary-only): Simplify.

* lisp/emacs-lisp/eieio-custom.el (eieio-widget-test): Remove dummy arg.
(eieio-object-value-get): Use eieio-object-set-name-string.

* lisp/emacs-lisp/eieio.el (make-instance): Simplify by not adding an object
name argument.
(eieio-object-name): Use eieio-object-name-string.
(eieio--object-names): New const.
(eieio-object-name-string, eieio-object-set-name-string): Re-implement
using a hashtable rather than a built-in slot.
(eieio-constructor): Rename from `constructor'.  Remove `newname' arg.
(clone): Don't mess with the object's "name".

* test/automated/eieio-test-persist.el (persistent-with-objs-slot-subs):
The type FOO-child is the same as FOO.

* test/automated/eieio-tests.el: Remove dummy object names.
This commit is contained in:
Stefan Monnier 2014-12-22 22:05:46 -05:00
parent d4a12e7a9a
commit ee93d7ad42
8 changed files with 167 additions and 135 deletions

View file

@ -1,3 +1,37 @@
2014-12-23 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el (make-instance): Simplify by not adding an object
name argument.
(eieio-object-name): Use eieio-object-name-string.
(eieio--object-names): New const.
(eieio-object-name-string, eieio-object-set-name-string): Re-implement
using a hashtable rather than a built-in slot.
(eieio-constructor): Rename from `constructor'. Remove `newname' arg.
(clone): Don't mess with the object's "name".
* emacs-lisp/eieio-custom.el (eieio-widget-test): Remove dummy arg.
(eieio-object-value-get): Use eieio-object-set-name-string.
* emacs-lisp/eieio-core.el (eieio--defalias): Follow aliases.
(eieio--object): Remove `name' field.
(eieio-defclass): Adjust to new convention where constructors don't
take an "object name" any more.
(eieio--defgeneric-init-form, eieio--defmethod): Follow aliases.
(eieio-validate-slot-value, eieio-oset-default)
(eieio-slot-name-index): Don't hardcode eieio--object-num-slots.
(eieio-generic-call-primary-only): Simplify.
* emacs-lisp/eieio-base.el (clone) <eieio-instance-inheritor>:
Use call-next-method.
(eieio-constructor): Rename from `constructor'.
(eieio-persistent-convert-list-to-object): Drop objname.
(eieio-persistent-validate/fix-slot-value): Don't hardcode
eieio--object-num-slots.
(eieio-named): Use a normal slot.
(slot-missing) <eieio-named>: Remove.
(eieio-object-name-string, eieio-object-set-name-string, clone)
<eieio-named>: New methods.
2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca> 2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio-core.el (eieio--class-v): Rename from class-v. * emacs-lisp/eieio-core.el (eieio--class-v): Rename from class-v.

View file

@ -63,25 +63,10 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
;; Throw the regular signal. ;; Throw the regular signal.
(call-next-method))) (call-next-method)))
(defmethod clone ((obj eieio-instance-inheritor) &rest params) (defmethod clone ((obj eieio-instance-inheritor) &rest _params)
"Clone OBJ, initializing `:parent' to OBJ. "Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS." All slots are unbound, except those initialized with PARAMS."
(let ((nobj (make-vector (length obj) eieio-unbound)) (let ((nobj (call-next-method)))
(nm (eieio--object-name obj))
(passname (and params (stringp (car params))))
(num 1))
(aset nobj 0 'object)
(setf (eieio--object-class nobj) (eieio--object-class obj))
;; The following was copied from the default clone.
(if (not passname)
(save-match-data
(if (string-match "-\\([0-9]+\\)" nm)
(setq num (1+ (string-to-number (match-string 1 nm)))
nm (substring nm 0 (match-beginning 0))))
(setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
(setf (eieio--object-name nobj) (car params)))
;; Now initialize from params.
(if params (shared-initialize nobj (if passname (cdr params) params)))
(oset nobj parent-instance obj) (oset nobj parent-instance obj)
nobj)) nobj))
@ -155,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
A singleton is a class which will only ever have one instance." A singleton is a class which will only ever have one instance."
:abstract t) :abstract t)
(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots) (defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots)
"Constructor for singleton CLASS. "Constructor for singleton CLASS.
NAME and SLOTS initialize the new object. NAME and SLOTS initialize the new object.
This constructor guarantees that no matter how many you request, This constructor guarantees that no matter how many you request,
@ -270,7 +255,7 @@ malicious code.
Note: This function recurses when a slot of :type of some object is Note: This function recurses when a slot of :type of some object is
identified, and needing more object creation." identified, and needing more object creation."
(let ((objclass (nth 0 inputlist)) (let ((objclass (nth 0 inputlist))
(objname (nth 1 inputlist)) ;; (objname (nth 1 inputlist))
(slots (nthcdr 2 inputlist)) (slots (nthcdr 2 inputlist))
(createslots nil)) (createslots nil))
@ -293,7 +278,7 @@ identified, and needing more object creation."
(setq slots (cdr (cdr slots)))) (setq slots (cdr (cdr slots))))
(apply 'make-instance objclass objname (nreverse createslots)) (apply #'make-instance objclass (nreverse createslots))
;;(eval inputlist) ;;(eval inputlist)
)) ))
@ -308,7 +293,8 @@ Second, any text properties will be stripped from strings."
(let ((slot-idx (eieio-slot-name-index class nil slot)) (let ((slot-idx (eieio-slot-name-index class nil slot))
(type nil) (type nil)
(classtype nil)) (classtype nil))
(setq slot-idx (- slot-idx 3)) (setq slot-idx (- slot-idx
(eval-when-compile eieio--object-num-slots)))
(setq type (aref (eieio--class-public-type (eieio--class-v class)) (setq type (aref (eieio--class-public-type (eieio--class-v class))
slot-idx)) slot-idx))
@ -463,34 +449,38 @@ instance."
;;; Named object ;;; Named object
;;
;; Named objects use the objects `name' as a slot, and that slot
;; is accessed with the `object-name' symbol.
(defclass eieio-named () (defclass eieio-named ()
() ((object-name :initarg :object-name :initform nil))
"Object with a name. "Object with a name."
Name storage already occurs in an object. This object provides get/set
access to it."
:abstract t) :abstract t)
(defmethod slot-missing ((obj eieio-named) (defmethod eieio-object-name-string ((obj eieio-named))
slot-name operation &optional new-value) "Return a string which is OBJ's name."
"Called when a non-existent slot is accessed. (or (slot-value obj 'object-name)
For variable `eieio-named', provide an imaginary `object-name' slot. (symbol-name (eieio-object-class obj))))
Argument OBJ is the named object.
Argument SLOT-NAME is the slot that was attempted to be accessed. (defmethod eieio-object-set-name-string ((obj eieio-named) name)
OPERATION is the type of access, such as `oref' or `oset'. "Set the string which is OBJ's NAME."
NEW-VALUE is the value that was being set into SLOT if OPERATION were (eieio--check-type stringp name)
a set type." (eieio-oset obj 'object-name name))
(if (memq slot-name '(object-name :object-name))
(cond ((eq operation 'oset) (defmethod clone ((obj eieio-named) &rest params)
(if (not (stringp new-value)) "Clone OBJ, initializing `:parent' to OBJ.
(signal 'invalid-slot-type All slots are unbound, except those initialized with PARAMS."
(list obj slot-name 'string new-value))) (let* ((newname (and (stringp (car params)) (pop params)))
(eieio-object-set-name-string obj new-value)) (nobj (apply #'call-next-method obj params))
(t (eieio-object-name-string obj))) (nm (slot-value obj 'object-name)))
(call-next-method))) (eieio-oset obj 'object-name
(or newname
(save-match-data
(if (and nm (string-match "-\\([0-9]+\\)" nm))
(let ((num (1+ (string-to-number
(match-string 1 nm)))))
(concat (substring nm 0 (match-beginning 0))
"-" (int-to-string num)))
(concat nm "-1")))))
nobj))
(provide 'eieio-base) (provide 'eieio-base)

View file

@ -39,6 +39,9 @@
"Like `defalias', but with less side-effects. "Like `defalias', but with less side-effects.
More specifically, it has no side-effects at all when the new function More specifically, it has no side-effects at all when the new function
definition is the same (`eq') as the old one." definition is the same (`eq') as the old one."
(while (and (fboundp name) (symbolp (symbol-function name)))
;; Follow aliases, so methods applied to obsolete aliases still work.
(setq name (symbol-function name)))
(unless (and (fboundp name) (unless (and (fboundp name)
(eq (symbol-function name) body)) (eq (symbol-function name) body))
(defalias name body))) (defalias name body)))
@ -167,8 +170,7 @@ Stored outright without modifications or stripping.")))
(eieio--define-field-accessors object (eieio--define-field-accessors object
(-unused-0 ;;Constant slot, set to `object'. (-unused-0 ;;Constant slot, set to `object'.
(class "class struct defining OBJ") (class "class struct defining OBJ")))
name)) ;FIXME: Get rid of this field!
;; FIXME: The constants below should have an `eieio-' prefix added!! ;; FIXME: The constants below should have an `eieio-' prefix added!!
(defconst eieio--method-static 0 "Index into :static tag on a method.") (defconst eieio--method-static 0 "Index into :static tag on a method.")
@ -480,10 +482,10 @@ See `defclass' for more information."
;; Create the test function ;; Create the test function
(let ((csym (intern (concat (symbol-name cname) "-p")))) (let ((csym (intern (concat (symbol-name cname) "-p"))))
(fset csym (fset csym
(list 'lambda (list 'obj) `(lambda (obj)
(format "Test OBJ to see if it an object of type %s" cname) ,(format "Test OBJ to see if it an object of type %s" cname)
(list 'and '(eieio-object-p obj) (and (eieio-object-p obj)
(list 'same-class-p 'obj cname))))) (same-class-p obj ',cname)))))
;; Make sure the method invocation order is a valid value. ;; Make sure the method invocation order is a valid value.
(let ((io (class-option-assoc options :method-invocation-order))) (let ((io (class-option-assoc options :method-invocation-order)))
@ -499,7 +501,7 @@ See `defclass' for more information."
"Test OBJ to see if it an object is a child of type %s" "Test OBJ to see if it an object is a child of type %s"
cname) cname)
(and (eieio-object-p obj) (and (eieio-object-p obj)
(object-of-class-p obj ,cname)))) (object-of-class-p obj ',cname))))
;; When using typep, (typep OBJ 'myclass) returns t for objects which ;; When using typep, (typep OBJ 'myclass) returns t for objects which
;; are subclasses of myclass. For our predicates, however, it is ;; are subclasses of myclass. For our predicates, however, it is
@ -722,9 +724,14 @@ See `defclass' for more information."
;; Non-abstract classes need a constructor. ;; Non-abstract classes need a constructor.
(fset cname (fset cname
`(lambda (newname &rest slots) `(lambda (&rest slots)
,(format "Create a new object with name NAME of class type %s" cname) ,(format "Create a new object with name NAME of class type %s" cname)
(apply #'constructor ,cname newname slots))) (if (and slots
(let ((x (car slots)))
(or (stringp x) (null x))))
(message "Obsolete name %S passed to %S constructor"
(pop slots) ',cname))
(apply #'eieio-constructor ',cname slots)))
) )
;; Set up a specialized doc string. ;; Set up a specialized doc string.
@ -761,7 +768,6 @@ See `defclass' for more information."
nil))) nil)))
(aset cache 0 'object) (aset cache 0 'object)
(setf (eieio--object-class cache) cname) (setf (eieio--object-class cache) cname)
(setf (eieio--object-name cache) 'default-cache-object)
(let ((eieio-skip-typecheck t)) (let ((eieio-skip-typecheck t))
;; All type-checking has been done to our satisfaction ;; All type-checking has been done to our satisfaction
;; before this call. Don't waste our time in this call.. ;; before this call. Don't waste our time in this call..
@ -1087,6 +1093,10 @@ the new child class."
(defun eieio--defgeneric-init-form (method doc-string) (defun eieio--defgeneric-init-form (method doc-string)
"Form to use for the initial definition of a generic." "Form to use for the initial definition of a generic."
(while (and (fboundp method) (symbolp (symbol-function method)))
;; Follow aliases, so methods applied to obsolete aliases still work.
(setq method (symbol-function method)))
(cond (cond
((or (not (fboundp method)) ((or (not (fboundp method))
(eq 'autoload (car-safe (symbol-function method)))) (eq 'autoload (car-safe (symbol-function method))))
@ -1198,6 +1208,11 @@ but remove reference to all implementations of METHOD."
;; Primary key. ;; Primary key.
;; (t eieio--method-primary) ;; (t eieio--method-primary)
(t (error "Unknown method kind %S" kind))))) (t (error "Unknown method kind %S" kind)))))
(while (and (fboundp method) (symbolp (symbol-function method)))
;; Follow aliases, so methods applied to obsolete aliases still work.
(setq method (symbol-function method)))
;; Make sure there is a generic (when called from defclass). ;; Make sure there is a generic (when called from defclass).
(eieio--defalias (eieio--defalias
method (eieio--defgeneric-init-form method (eieio--defgeneric-init-form
@ -1253,7 +1268,7 @@ an error."
(if eieio-skip-typecheck (if eieio-skip-typecheck
nil nil
;; Trim off object IDX junk added in for the object index. ;; Trim off object IDX junk added in for the object index.
(setq slot-idx (- slot-idx 3)) (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
(let ((st (aref (eieio--class-public-type (eieio--class-v class)) slot-idx))) (let ((st (aref (eieio--class-public-type (eieio--class-v class)) slot-idx)))
(if (not (eieio-perform-slot-validation st value)) (if (not (eieio-perform-slot-validation st value))
(signal 'invalid-slot-type (list class slot st value)))))) (signal 'invalid-slot-type (list class slot st value))))))
@ -1324,7 +1339,8 @@ Fills in OBJ's SLOT with its default value."
;;(signal 'invalid-slot-name (list (class-name cl) slot)) ;;(signal 'invalid-slot-name (list (class-name cl) slot))
) )
(eieio-barf-if-slot-unbound (eieio-barf-if-slot-unbound
(let ((val (nth (- c 3) (eieio--class-public-d (eieio--class-v cl))))) (let ((val (nth (- c (eval-when-compile eieio--object-num-slots))
(eieio--class-public-d (eieio--class-v cl)))))
(eieio-default-eval-maybe val)) (eieio-default-eval-maybe val))
obj cl 'oref-default)))) obj cl 'oref-default))))
@ -1382,7 +1398,8 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(signal 'invalid-slot-name (list (eieio-class-name class) slot))) (signal 'invalid-slot-name (list (eieio-class-name class) slot)))
(eieio-validate-slot-value class c value slot) (eieio-validate-slot-value class c value slot)
;; Set this into the storage for defaults. ;; Set this into the storage for defaults.
(setcar (nthcdr (- c 3) (eieio--class-public-d (eieio--class-v class))) (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
(eieio--class-public-d (eieio--class-v class)))
value) value)
;; Take the value, and put it into our cache object. ;; Take the value, and put it into our cache object.
(eieio-oset (eieio--class-default-object-cache (eieio--class-v class)) (eieio-oset (eieio--class-default-object-cache (eieio--class-v class))
@ -1420,18 +1437,18 @@ reverse-lookup that name, and recurse with the associated slot value."
(if (integerp fsi) (if (integerp fsi)
(cond (cond
((not (cdr fsym)) ((not (cdr fsym))
(+ 3 fsi)) (+ (eval-when-compile eieio--object-num-slots) fsi))
((and (eq (cdr fsym) 'protected) ((and (eq (cdr fsym) 'protected)
(eieio--scoped-class) (eieio--scoped-class)
(or (child-of-class-p class (eieio--scoped-class)) (or (child-of-class-p class (eieio--scoped-class))
(and (eieio-object-p obj) (and (eieio-object-p obj)
(child-of-class-p class (eieio--object-class obj))))) (child-of-class-p class (eieio--object-class obj)))))
(+ 3 fsi)) (+ (eval-when-compile eieio--object-num-slots) fsi))
((and (eq (cdr fsym) 'private) ((and (eq (cdr fsym) 'private)
(or (and (eieio--scoped-class) (or (and (eieio--scoped-class)
(eieio-slot-originating-class-p (eieio--scoped-class) slot)) (eieio-slot-originating-class-p (eieio--scoped-class) slot))
eieio-initializing-object)) eieio-initializing-object))
(+ 3 fsi)) (+ (eval-when-compile eieio--object-num-slots) fsi))
(t nil)) (t nil))
(let ((fn (eieio-initarg-to-attribute class slot))) (let ((fn (eieio-initarg-to-attribute class slot)))
(if fn (eieio-slot-name-index class obj fn) nil))))) (if fn (eieio-slot-name-index class obj fn) nil)))))
@ -1778,12 +1795,8 @@ for this common case to improve performance."
(setq mclass (eieio--object-class firstarg))) (setq mclass (eieio--object-class firstarg)))
((not firstarg) ((not firstarg)
(error "Method %s called on nil" method)) (error "Method %s called on nil" method))
((not (eieio-object-p firstarg))
(error "Primary-only method %s called on something not an object" method))
(t (t
(error "EIEIO Error: Improperly classified method %s as primary only" (error "Primary-only method %s called on something not an object" method)))
method)
))
;; Make sure the class is a valid class ;; Make sure the class is a valid class
;; mclass can be nil (meaning a generic for should be used. ;; mclass can be nil (meaning a generic for should be used.
;; mclass cannot have a value that is not a class, however. ;; mclass cannot have a value that is not a class, however.

View file

@ -70,7 +70,7 @@ of these.")
:documentation "A number of thingies.")) :documentation "A number of thingies."))
"A class for testing the widget on.") "A class for testing the widget on.")
(defcustom eieio-widget-test (eieio-widget-test-class "Foo") (defcustom eieio-widget-test (eieio-widget-test-class)
"Test variable for editing an object." "Test variable for editing an object."
:type 'object :type 'object
:group 'eieio) :group 'eieio)
@ -317,7 +317,7 @@ Optional argument IGNORE is an extraneous parameter."
fgroup (cdr fgroup) fgroup (cdr fgroup)
fcust (cdr fcust))) fcust (cdr fcust)))
;; Set any name updates on it. ;; Set any name updates on it.
(if name (setf (eieio--object-name obj) name)) (if name (eieio-object-set-name-string obj name))
;; This is the same object we had before. ;; This is the same object we had before.
obj)) obj))

View file

@ -144,12 +144,7 @@ In EIEIO, the class' constructor requires a name for use when printing.
`make-instance' in CLOS doesn't use names the way Emacs does, so the `make-instance' in CLOS doesn't use names the way Emacs does, so the
class is used as the name slot instead when INITARGS doesn't start with class is used as the name slot instead when INITARGS doesn't start with
a string." a string."
(if (and (car initargs) (stringp (car initargs))) (apply (class-constructor class) initargs))
(apply (class-constructor class) initargs)
(apply (class-constructor class)
(cond ((symbolp class) (symbol-name class))
(t (format "%S" class)))
initargs)))
;;; CLOS methods and generics ;;; CLOS methods and generics
@ -279,20 +274,28 @@ variable name of the same name as the slot."
If EXTRA, include that in the string returned to represent the symbol." If EXTRA, include that in the string returned to represent the symbol."
(eieio--check-type eieio-object-p obj) (eieio--check-type eieio-object-p obj)
(format "#<%s %s%s>" (symbol-name (eieio--object-class obj)) (format "#<%s %s%s>" (symbol-name (eieio--object-class obj))
(eieio--object-name obj) (or extra ""))) (eieio-object-name-string obj) (or extra "")))
(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
(defun eieio-object-name-string (obj) "Return a string which is OBJ's name." (defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key))
(eieio--check-type eieio-object-p obj)
(eieio--object-name obj)) ;; In the past, every EIEIO object had a `name' field, so we had the two method
;; 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"))
(or (gethash obj eieio--object-names)
(symbol-name (eieio-object-class obj))))
(define-obsolete-function-alias (define-obsolete-function-alias
'object-name-string #'eieio-object-name-string "24.4") 'object-name-string #'eieio-object-name-string "24.4")
(defun eieio-object-set-name-string (obj name) (defmethod eieio-object-set-name-string (obj name)
"Set the string which is OBJ's NAME." "Set the string which is OBJ's NAME."
(eieio--check-type eieio-object-p obj) (declare (obsolete eieio-named "25.1"))
(eieio--check-type stringp name) (eieio--check-type stringp name)
(setf (eieio--object-name obj) name)) (setf (gethash obj eieio--object-names) name))
(define-obsolete-function-alias (define-obsolete-function-alias
'object-set-name-string 'eieio-object-set-name-string "24.4") 'object-set-name-string 'eieio-object-set-name-string "24.4")
@ -574,20 +577,19 @@ This class is not stored in the `parent' slot of a class vector."
(defalias 'standard-class 'eieio-default-superclass) (defalias 'standard-class 'eieio-default-superclass)
(defgeneric constructor (class newname &rest slots) (defgeneric eieio-constructor (class &rest slots)
"Default constructor for CLASS `eieio-default-superclass'.") "Default constructor for CLASS `eieio-default-superclass'.")
(defmethod constructor :static (define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
((class eieio-default-superclass) newname &rest slots)
(defmethod eieio-constructor :static
((class eieio-default-superclass) &rest slots)
"Default constructor for CLASS `eieio-default-superclass'. "Default constructor for CLASS `eieio-default-superclass'.
NEWNAME is the name to be given to the constructed object.
SLOTS are the initialization slots used by `shared-initialize'. SLOTS are the initialization slots used by `shared-initialize'.
This static method is called when an object is constructed. This static method is called when an object is constructed.
It allocates the vector used to represent an EIEIO object, and then It allocates the vector used to represent an EIEIO object, and then
calls `shared-initialize' on that object." calls `shared-initialize' on that object."
(let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class))))) (let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class)))))
;; Update the name for the newly created object.
(setf (eieio--object-name new-object) newname)
;; Call the initialize method on the new object with the slots ;; Call the initialize method on the new object with the slots
;; that were passed down to us. ;; that were passed down to us.
(initialize-instance new-object slots) (initialize-instance new-object slots)
@ -715,18 +717,10 @@ first and modify the returned object.")
(defmethod clone ((obj eieio-default-superclass) &rest params) (defmethod clone ((obj eieio-default-superclass) &rest params)
"Make a copy of OBJ, and then apply PARAMS." "Make a copy of OBJ, and then apply PARAMS."
(let ((nobj (copy-sequence obj)) (let ((nobj (copy-sequence obj)))
(nm (eieio--object-name obj)) (if (stringp (car params))
(passname (and params (stringp (car params)))) (message "Obsolete name %S passed to clone" (pop params)))
(num 1)) (if params (shared-initialize nobj params))
(if params (shared-initialize nobj (if passname (cdr params) params)))
(if (not passname)
(save-match-data
(if (string-match "-\\([0-9]+\\)" nm)
(setq num (1+ (string-to-number (match-string 1 nm)))
nm (substring nm 0 (match-beginning 0))))
(setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
(setf (eieio--object-name nobj) (car params)))
nobj)) nobj))
(defgeneric destructor (this &rest params) (defgeneric destructor (this &rest params)
@ -889,7 +883,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
;;; Start of automatically extracted autoloads. ;;; Start of automatically extracted autoloads.
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "6413249ec10091eb7094238637b40e2c") ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "3a6fffe3af331fe960f967d0da99e8e9")
;;; Generated autoloads from eieio-custom.el ;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\ (autoload 'customize-object "eieio-custom" "\
@ -900,7 +894,7 @@ Optional argument GROUP is the sub-group of slots to display.
;;;*** ;;;***
;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "6f114a48de40212413d2776eedc3ec14") ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "2ff7d98da3f84c6af5c873ffb781930e")
;;; Generated autoloads from eieio-opt.el ;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\ (autoload 'eieio-browse "eieio-opt" "\

View file

@ -174,17 +174,18 @@
(defclass C-base2 () ()) (defclass C-base2 () ())
(defclass C (C-base1 C-base2) ()) (defclass C (C-base1 C-base2) ())
;; Just use the obsolete name once, to make sure it also works.
(defmethod constructor :STATIC ((p C-base1) &rest args) (defmethod constructor :STATIC ((p C-base1) &rest args)
(eieio-test-method-store) (eieio-test-method-store)
(if (next-method-p) (call-next-method)) (if (next-method-p) (call-next-method))
) )
(defmethod constructor :STATIC ((p C-base2) &rest args) (defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
(eieio-test-method-store) (eieio-test-method-store)
(if (next-method-p) (call-next-method)) (if (next-method-p) (call-next-method))
) )
(defmethod constructor :STATIC ((p C) &rest args) (defmethod eieio-constructor :STATIC ((p C) &rest args)
(eieio-test-method-store) (eieio-test-method-store)
(call-next-method) (call-next-method)
) )

View file

@ -175,7 +175,7 @@ persistent class.")
(defclass persistent-with-objs-slot-subs (eieio-persistent) (defclass persistent-with-objs-slot-subs (eieio-persistent)
((pnp :initarg :pnp ((pnp :initarg :pnp
:type (or null persist-not-persistent-child) :type (or null persist-not-persistent)
:initform nil)) :initform nil))
"Class for testing the saving of slots with objects in them.") "Class for testing the saving of slots with objects in them.")

View file

@ -157,7 +157,7 @@
(ert-deftest eieio-test-02-abstract-class () (ert-deftest eieio-test-02-abstract-class ()
;; Abstract classes cannot be instantiated, so this should throw an ;; Abstract classes cannot be instantiated, so this should throw an
;; error ;; error
(should-error (abstract-class "Test"))) (should-error (abstract-class)))
(defgeneric generic1 () "First generic function") (defgeneric generic1 () "First generic function")
@ -179,7 +179,7 @@
"Method generic1 that can take a non-object." "Method generic1 that can take a non-object."
not-an-object) not-an-object)
(let ((ans-obj (generic1 (class-a "test"))) (let ((ans-obj (generic1 (class-a)))
(ans-num (generic1 666))) (ans-num (generic1 666)))
(should (eq ans-obj 'monkey)) (should (eq ans-obj 'monkey))
(should (eq ans-num 666)))) (should (eq ans-num 666))))
@ -200,7 +200,7 @@ Argument C is the class bound to this static method."
;; Call static method on a class and see if it worked ;; Call static method on a class and see if it worked
(static-method-class-method static-method-class 'class) (static-method-class-method static-method-class 'class)
(should (eq (oref static-method-class some-slot) 'class)) (should (eq (oref static-method-class some-slot) 'class))
(static-method-class-method (static-method-class "test") 'object) (static-method-class-method (static-method-class) 'object)
(should (eq (oref static-method-class some-slot) 'object))) (should (eq (oref static-method-class some-slot) 'object)))
(ert-deftest eieio-test-05-static-method-2 () (ert-deftest eieio-test-05-static-method-2 ()
@ -216,7 +216,7 @@ Argument C is the class bound to this static method."
(static-method-class-method static-method-class-2 'class) (static-method-class-method static-method-class-2 'class)
(should (eq (oref static-method-class-2 some-slot) 'moose-class)) (should (eq (oref static-method-class-2 some-slot) 'moose-class))
(static-method-class-method (static-method-class-2 "test") 'object) (static-method-class-method (static-method-class-2) 'object)
(should (eq (oref static-method-class-2 some-slot) 'moose-object))) (should (eq (oref static-method-class-2 some-slot) 'moose-object)))
@ -230,14 +230,14 @@ Argument C is the class bound to this static method."
(defvar eitest-b nil) (defvar eitest-b nil)
(ert-deftest eieio-test-06-allocate-objects () (ert-deftest eieio-test-06-allocate-objects ()
;; allocate an object to use ;; allocate an object to use
(should (setq eitest-ab (class-ab "abby"))) (should (setq eitest-ab (class-ab)))
(should (setq eitest-a (class-a "aye"))) (should (setq eitest-a (class-a)))
(should (setq eitest-b (class-b "fooby")))) (should (setq eitest-b (class-b))))
(ert-deftest eieio-test-07-make-instance () (ert-deftest eieio-test-07-make-instance ()
(should (make-instance 'class-ab)) (should (make-instance 'class-ab))
(should (make-instance 'class-a :water 'cho)) (should (make-instance 'class-a :water 'cho))
(should (make-instance 'class-b "a name"))) (should (make-instance 'class-b)))
(defmethod class-cn ((a class-a)) (defmethod class-cn ((a class-a))
"Try calling `call-next-method' when there isn't one. "Try calling `call-next-method' when there isn't one.
@ -354,7 +354,7 @@ METHOD is the method that was attempting to be called."
(call-next-method) (call-next-method)
(oset a test-tag 1)) (oset a test-tag 1))
(let ((ca (class-a "class act"))) (let ((ca (class-a)))
(should-not (/= (oref ca test-tag) 2)))) (should-not (/= (oref ca test-tag) 2))))
@ -403,7 +403,7 @@ METHOD is the method that was attempting to be called."
(t (call-next-method)))) (t (call-next-method))))
(ert-deftest eieio-test-17-virtual-slot () (ert-deftest eieio-test-17-virtual-slot ()
(setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1)) (setq eitest-vsca (virtual-slot-class :base-value 1))
;; Check slot values ;; Check slot values
(should (= (oref eitest-vsca :base-value) 1)) (should (= (oref eitest-vsca :base-value) 1))
(should (= (oref eitest-vsca :derived-value) 2)) (should (= (oref eitest-vsca :derived-value) 2))
@ -418,7 +418,7 @@ METHOD is the method that was attempting to be called."
;; should also be possible to initialize instance using virtual slot ;; should also be possible to initialize instance using virtual slot
(setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5)) (setq eitest-vscb (virtual-slot-class :derived-value 5))
(should (= (oref eitest-vscb :base-value) 4)) (should (= (oref eitest-vscb :base-value) 4))
(should (= (oref eitest-vscb :derived-value) 5))) (should (= (oref eitest-vscb :derived-value) 5)))
@ -444,7 +444,7 @@ METHOD is the method that was attempting to be called."
;; After setting 'water to 'moose, make sure a new object has ;; After setting 'water to 'moose, make sure a new object has
;; the right stuff. ;; the right stuff.
(oset-default (eieio-object-class eitest-a) water 'penguin) (oset-default (eieio-object-class eitest-a) water 'penguin)
(should (eq (oref (class-a "foo") water) 'penguin)) (should (eq (oref (class-a) water) 'penguin))
;; Revert the above ;; Revert the above
(defmethod slot-unbound ((a class-a) &rest foo) (defmethod slot-unbound ((a class-a) &rest foo)
@ -458,12 +458,12 @@ METHOD is the method that was attempting to be called."
;; We should not be able to set a string here ;; We should not be able to set a string here
(should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type) (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
(should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type) (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
(should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type)) (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type))
(ert-deftest eieio-test-20-class-allocated-slots () (ert-deftest eieio-test-20-class-allocated-slots ()
;; Test out class allocated slots ;; Test out class allocated slots
(defvar eitest-aa nil) (defvar eitest-aa nil)
(setq eitest-aa (class-a "another")) (setq eitest-aa (class-a))
;; Make sure class slots do not track between objects ;; Make sure class slots do not track between objects
(let ((newval 'moose)) (let ((newval 'moose))
@ -498,7 +498,7 @@ METHOD is the method that was attempting to be called."
(ert-deftest eieio-test-21-eval-at-construction-time () (ert-deftest eieio-test-21-eval-at-construction-time ()
;; initforms that need to be evalled at construction time. ;; initforms that need to be evalled at construction time.
(setq eieio-test-permuting-value 2) (setq eieio-test-permuting-value 2)
(setq eitest-pvinit (inittest "permuteme")) (setq eitest-pvinit (inittest))
(should (eq (oref eitest-pvinit staticval) 1)) (should (eq (oref eitest-pvinit staticval) 1))
(should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value)) (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
@ -514,11 +514,11 @@ METHOD is the method that was attempting to be called."
"Test class that will be a calculated value.") "Test class that will be a calculated value.")
(defclass eitest-superior nil (defclass eitest-superior nil
((sub :initform (eitest-subordinate "test") ((sub :initform (eitest-subordinate)
:type eitest-subordinate)) :type eitest-subordinate))
"A class with an initform that creates a class.") "A class with an initform that creates a class.")
(should (setq eitest-tests (eitest-superior "test"))) (should (setq eitest-tests (eitest-superior)))
(should-error (should-error
(eval (eval
@ -546,8 +546,8 @@ METHOD is the method that was attempting to be called."
(should (not (class-a-child-p "foo")))) (should (not (class-a-child-p "foo"))))
(ert-deftest eieio-test-24-object-predicates () (ert-deftest eieio-test-24-object-predicates ()
(let ((listooa (list (class-ab "ab") (class-a "a"))) (let ((listooa (list (class-ab) (class-a)))
(listoob (list (class-ab "ab") (class-b "b")))) (listoob (list (class-ab) (class-b))))
(should (class-a-list-p listooa)) (should (class-a-list-p listooa))
(should (class-b-list-p listoob)) (should (class-b-list-p listoob))
(should-not (class-b-list-p listooa)) (should-not (class-b-list-p listooa))
@ -555,7 +555,7 @@ METHOD is the method that was attempting to be called."
(defvar eitest-t1 nil) (defvar eitest-t1 nil)
(ert-deftest eieio-test-25-slot-tests () (ert-deftest eieio-test-25-slot-tests ()
(setq eitest-t1 (class-c "C1")) (setq eitest-t1 (class-c))
;; Slot initialization ;; Slot initialization
(should (eq (oref eitest-t1 slot-1) 'moose)) (should (eq (oref eitest-t1 slot-1) 'moose))
(should (eq (oref eitest-t1 :moose) 'moose)) (should (eq (oref eitest-t1 :moose) 'moose))
@ -564,7 +564,7 @@ METHOD is the method that was attempting to be called."
;; Check private slot accessor ;; Check private slot accessor
(should (string= (get-slot-2 eitest-t1) "penguin")) (should (string= (get-slot-2 eitest-t1) "penguin"))
;; Pass string instead of symbol ;; Pass string instead of symbol
(should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type) (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
(should (eq (get-slot-3 eitest-t1) 'emu)) (should (eq (get-slot-3 eitest-t1) 'emu))
(should (eq (get-slot-3 class-c) 'emu)) (should (eq (get-slot-3 class-c) 'emu))
;; Check setf ;; Check setf
@ -576,13 +576,13 @@ METHOD is the method that was attempting to be called."
(defvar eitest-t2 nil) (defvar eitest-t2 nil)
(ert-deftest eieio-test-26-default-inheritance () (ert-deftest eieio-test-26-default-inheritance ()
;; See previous test, nor for subclass ;; See previous test, nor for subclass
(setq eitest-t2 (class-subc "subc")) (setq eitest-t2 (class-subc))
(should (eq (oref eitest-t2 slot-1) 'moose)) (should (eq (oref eitest-t2 slot-1) 'moose))
(should (eq (oref eitest-t2 :moose) 'moose)) (should (eq (oref eitest-t2 :moose) 'moose))
(should (string= (get-slot-2 eitest-t2) "linux")) (should (string= (get-slot-2 eitest-t2) "linux"))
(should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
(should (string= (get-slot-2 eitest-t2) "linux")) (should (string= (get-slot-2 eitest-t2) "linux"))
(should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type)) (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
;;(ert-deftest eieio-test-27-inherited-new-value () ;;(ert-deftest eieio-test-27-inherited-new-value ()
;;; HACK ALERT: The new value of a class slot is inherited by the ;;; HACK ALERT: The new value of a class slot is inherited by the
@ -646,8 +646,8 @@ Do not override for `prot-2'."
(defvar eitest-p1 nil) (defvar eitest-p1 nil)
(defvar eitest-p2 nil) (defvar eitest-p2 nil)
(ert-deftest eieio-test-28-slot-protection () (ert-deftest eieio-test-28-slot-protection ()
(setq eitest-p1 (prot-1 "")) (setq eitest-p1 (prot-1))
(setq eitest-p2 (prot-2 "")) (setq eitest-p2 (prot-2))
;; Access public slots ;; Access public slots
(oref eitest-p1 slot-1) (oref eitest-p1 slot-1)
(oref eitest-p2 slot-1) (oref eitest-p2 slot-1)
@ -742,7 +742,7 @@ Subclasses to override slot attributes.")
"This class should throw an error."))) "This class should throw an error.")))
;; Initform should override instance allocation ;; Initform should override instance allocation
(let ((obj (slotattr-ok "moose"))) (let ((obj (slotattr-ok)))
(should (eq (oref obj initform) 'no-init)))) (should (eq (oref obj initform) 'no-init))))
(defclass slotattr-class-base () (defclass slotattr-class-base ()
@ -825,7 +825,7 @@ Subclasses to override slot attributes.")
(ert-deftest eieio-test-32-test-clone-boring-objects () (ert-deftest eieio-test-32-test-clone-boring-objects ()
;; A simple make instance with EIEIO extension ;; A simple make instance with EIEIO extension
(should (setq eitest-CLONETEST1 (make-instance 'class-a "a"))) (should (setq eitest-CLONETEST1 (make-instance 'class-a)))
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))) (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
;; CLOS form of make-instance ;; CLOS form of make-instance
@ -839,7 +839,7 @@ Subclasses to override slot attributes.")
(ert-deftest eieio-test-33-instance-tracker () (ert-deftest eieio-test-33-instance-tracker ()
(let (IT-list IT1) (let (IT-list IT1)
(should (setq IT1 (IT "trackme"))) (should (setq IT1 (IT)))
;; The instance tracker must find this ;; The instance tracker must find this
(should (eieio-instance-tracker-find 'die 'slot1 'IT-list)) (should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
;; Test deletion ;; Test deletion
@ -851,8 +851,8 @@ Subclasses to override slot attributes.")
"A Singleton test object.") "A Singleton test object.")
(ert-deftest eieio-test-34-singletons () (ert-deftest eieio-test-34-singletons ()
(let ((obj1 (SINGLE "Moose")) (let ((obj1 (SINGLE))
(obj2 (SINGLE "Cow"))) (obj2 (SINGLE)))
(should (eieio-object-p obj1)) (should (eieio-object-p obj1))
(should (eieio-object-p obj2)) (should (eieio-object-p obj2))
(should (eq obj1 obj2)) (should (eq obj1 obj2))
@ -865,7 +865,7 @@ Subclasses to override slot attributes.")
(ert-deftest eieio-test-35-named-object () (ert-deftest eieio-test-35-named-object ()
(let (N) (let (N)
(should (setq N (NAMED "Foo"))) (should (setq N (NAMED :object-name "Foo")))
(should (string= "Foo" (oref N object-name))) (should (string= "Foo" (oref N object-name)))
(should-error (oref N missing-slot) :type 'invalid-slot-name) (should-error (oref N missing-slot) :type 'invalid-slot-name)
(oset N object-name "NewName") (oset N object-name "NewName")