+2015-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/eieio.el (with-slots): Use macroexp-let2.
+ (object-class-fast): Change recommend replacement.
+ (eieio-object-class): Rewrite.
+ (slot-exists-p): Adjust to new slot representation.
+ (initialize-instance): Adjust to new slot representation.
+ (object-write): Adjust to new slot representation.
+
+ * emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function
+ extracted from eieio-help-class-slots.
+ (eieio-help-class-slots): Use it. Adjust to new slot representation.
+
+ * emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots):
+ Declare to silence warnings.
+ (data-debug-insert-object-button): Avoid `object-slots'.
+ (data-debug/eieio-insert-slots): Adjust to new slot representation.
+
+ * emacs-lisp/eieio-custom.el (eieio-object-value-create)
+ (eieio-object-value-get): Adjust to new slot representation.
+
+ EIEIO: Change class's representation to unify instance and class slots
+ * emacs-lisp/eieio-core.el (eieio--class): Change field names and order
+ to match those of cl--class; use cl--slot for both instance slots and
+ class slots.
+ (eieio--object-num-slots): Use cl-struct-slot-info.
+ (eieio--object-class): Rename from eieio--object-class-object.
+ (eieio--object-class-name): Remove.
+ (eieio-defclass-internal): Adjust to new slot representation.
+ Store doc in class rather than in `variable-documentation'.
+ (eieio--perform-slot-validation-for-default): Change API to take
+ a slot object.
+ (eieio--slot-override): New function.
+ (eieio--add-new-slot): Rewrite.
+ (eieio-copy-parents-into-subclass): Rewrite.
+ (eieio--validate-slot-value, eieio--validate-class-slot-value)
+ (eieio-oref-default, eieio-oset-default)
+ (eieio--class-slot-name-index, eieio-set-defaults): Adjust to new
+ slot representation.
+ (eieio--c3-merge-lists): Simplify.
+ (eieio--class/struct-parents): New function.
+ (eieio--class-precedence-bfs): Use it.
+
+ * emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers):
+ Extract from eieio--generic-static-symbol-generalizer.
+ (eieio--generic-static-symbol-generalizer): Use it.
+
+ * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
+ Manually map initargs to slot names.
+ (eieio-persistent-validate/fix-slot-value): Adjust to new
+ slot representation.
+
+ * emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'.
+
2015-03-19 Vibhav Pant <vibhavp@gmail.com>
* lisp/leim/quail/hangul.el
;; Intended to be shared between defstruct and defclass.
(name nil :type symbol) ;The type name.
(docstring nil :type string)
- (parents nil :type (or cl--class (list-of cl--class)))
+ ;; For structs there can only be one parent, but when EIEIO classes inherit
+ ;; from cl--class, we'll need this to hold a list.
+ (parents nil :type (list-of cl--class))
(slots nil :type (vector cl-slot-descriptor))
(index-table nil :type hash-table))
Note: This function recurses when a slot of :type of some object is
identified, and needing more object creation."
- (let ((objclass (nth 0 inputlist))
- ;; (objname (nth 1 inputlist))
- (slots (nthcdr 2 inputlist))
- (createslots nil))
-
- ;; If OBJCLASS is an eieio autoload object, then we need to load it.
- (eieio-class-un-autoload objclass)
+ (let* ((objclass (nth 0 inputlist))
+ ;; (objname (nth 1 inputlist))
+ (slots (nthcdr 2 inputlist))
+ (createslots nil)
+ (class
+ (progn
+ ;; If OBJCLASS is an eieio autoload object, then we need to
+ ;; load it.
+ (eieio-class-un-autoload objclass)
+ (eieio--class-object objclass))))
(while slots
- (let ((name (car slots))
+ (let ((initarg (car slots))
(value (car (cdr slots))))
;; Make sure that the value proposed for SLOT is valid.
;; In addition, strip out quotes, list functions, and update
;; object constructors as needed.
(setq value (eieio-persistent-validate/fix-slot-value
- (eieio--class-v objclass) name value))
+ class (eieio--initarg-to-attribute class initarg) value))
- (push name createslots)
+ (push initarg createslots)
(push value createslots)
)
Second, any text properties will be stripped from strings."
(cond ((consp proposed-value)
;; Lists with something in them need special treatment.
- (let ((slot-idx (eieio--slot-name-index class slot))
- (type nil)
- (classtype nil))
- (setq slot-idx (- slot-idx
+ (let* ((slot-idx (- (eieio--slot-name-index class slot)
(eval-when-compile eieio--object-num-slots)))
- (setq type (aref (eieio--class-public-type class)
- slot-idx))
-
- (setq classtype (eieio-persistent-slot-type-is-class-p
- type))
+ (type (cl--slot-descriptor-type (aref (eieio--class-slots class)
+ slot-idx)))
+ (classtype (eieio-persistent-slot-type-is-class-p type)))
(cond ((eq (car proposed-value) 'quote)
(car (cdr proposed-value)))
(defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
+(defun eieio--generic-static-symbol-specializers (tag)
+ (cl-assert (or (null tag) (eieio--class-p tag)))
+ (when (eieio--class-p tag)
+ (let ((superclasses (eieio--generic-subclass-specializers tag))
+ (specializers ()))
+ (dolist (superclass superclasses)
+ (push superclass specializers)
+ (push `(eieio--static ,(cadr superclass)) specializers))
+ (nreverse specializers))))
+
(defconst eieio--generic-static-symbol-generalizer
(cl-generic-make-generalizer
;; Give it a slightly higher priority than `subclass' so that the
;; interleaved list comes before subclass's non-interleaved list.
61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name)))
- (lambda (tag)
- (when (eieio--class-p tag)
- (let ((superclasses (eieio--generic-subclass-specializers tag))
- (specializers ()))
- (dolist (superclass superclasses)
- (push superclass specializers)
- (push `(eieio--static ,(cadr superclass)) specializers))
- (nreverse specializers))))))
+ #'eieio--generic-static-symbol-specializers))
(defconst eieio--generic-static-object-generalizer
(cl-generic-make-generalizer
;; Give it a slightly higher priority than `class' so that the
(let ((superclasses (eieio--class-precedence-list tag))
(specializers ()))
(dolist (superclass superclasses)
- (setq superclass (eieio--class-symbol superclass))
+ (setq superclass (eieio--class-name superclass))
(push superclass specializers)
(push `(eieio--static ,superclass) specializers))
(nreverse specializers))))))
;; Arrange for field access not to bother checking if the access is indeed
;; made to an eieio--class object.
(cl-declaim (optimize (safety 0)))
+
(cl-defstruct (eieio--class
(:constructor nil)
- (:constructor eieio--class-make (symbol &aux (tag 'defclass)))
+ (:constructor eieio--class-make (name &aux (tag 'defclass)))
(:type vector)
(:copier nil))
;; We use an untagged cl-struct, with our own hand-made tag as first field
;; predicate for us), but that breaks compatibility with .elc files compiled
;; against older versions of EIEIO.
tag
- symbol ;; symbol (self-referencing)
- parent children
- symbol-hashtable ;; hashtable permitting fast access to variable position indexes
- ;; @todo
- ;; the word "public" here is leftovers from the very first version.
- ;; Get rid of it!
- public-a ;; class attribute index
- public-d ;; class attribute defaults index
- public-doc ;; class documentation strings for attributes
- public-type ;; class type for a slot
- public-custom ;; class custom type for a slot
- public-custom-label ;; class custom group for a slot
- public-custom-group ;; class custom group for a slot
- public-printer ;; printer for a slot
- protection ;; protection for a slot
+ ;; Fields we could inherit from cl--class (if we used a tagged cl-struct):
+ (name nil :type symbol) ;The type name.
+ (docstring nil :type string)
+ (parents nil :type (or eieio--class (list-of eieio--class)))
+ (slots nil :type (vector cl-slot-descriptor))
+ (index-table nil :type hash-table)
+ ;; Fields specific to EIEIO classes:
+ children
initarg-tuples ;; initarg tuples list
- class-allocation-a ;; class allocated attributes
- class-allocation-doc ;; class allocated documentation
- class-allocation-type ;; class allocated value type
- class-allocation-custom ;; class allocated custom descriptor
- class-allocation-custom-label ;; class allocated custom descriptor
- class-allocation-custom-group ;; class allocated custom group
- class-allocation-printer ;; class allocated printer for a slot
- class-allocation-protection ;; class allocated protection list
+ (class-slots nil :type eieio--slot)
class-allocation-values ;; class allocated value vector
default-object-cache ;; what a newly created object would look like.
; This will speed up instantiation time as
;; object/struct in its `symbol-value' slot.
class-tag)
-(eval-and-compile
+(eval-when-compile
(defconst eieio--object-num-slots
- (length (get 'eieio--object 'cl-struct-slots))))
+ (length (cl-struct-slot-info 'eieio--object))))
-(defsubst eieio--object-class-object (obj)
+(defsubst eieio--object-class (obj)
(symbol-value (eieio--object-class-tag obj)))
-(defsubst eieio--object-class-name (obj)
- ;; FIXME: Most uses of this function should be changed to use
- ;; eieio--object-class-object instead!
- (eieio--class-symbol (eieio--object-class-object obj)))
-
\f
;;; Important macros used internally in eieio.
"Return a Lisp like symbol name for CLASS."
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
- (eieio--class-symbol class))
+ (eieio--class-name class))
(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
(defalias 'eieio--class-constructor #'identity
(mapc (lambda (g) (cl-pushnew g groups :test #'equal))
(eieio--class-option c :custom-groups))
;; Save parent in child.
- (push c (eieio--class-parent newc))))))
+ (push c (eieio--class-parents newc))))))
;; Reverse the list of our parents so that they are prioritized in
;; the same order as specified in the code.
- (cl-callf nreverse (eieio--class-parent newc)))
+ (cl-callf nreverse (eieio--class-parents newc)))
;; If there is nothing to loop over, then inherit from the
;; default superclass.
(unless (eq cname 'eieio-default-superclass)
;; save new child in parent
(cl-pushnew cname (eieio--class-children eieio-default-superclass))
;; save parent in child
- (setf (eieio--class-parent newc) (list eieio-default-superclass))))
+ (setf (eieio--class-parents newc) (list eieio-default-superclass))))
;; turn this into a usable self-pointing symbol; FIXME: Why?
(when eieio-backward-compatibility
(make-obsolete-variable
initarg (format "use '%s instead" initarg) "25.1"))))
- ;; The customgroup should be a list of symbols
- (cond ((null customg)
+ ;; The customgroup should be a list of symbols.
+ (cond ((and (null customg) custom)
(setq customg '(default)))
((not (listp customg))
(setq customg (list customg))))
- ;; The customgroup better be a symbol, or list of symbols.
- (mapc (lambda (cg)
- (if (not (symbolp cg))
- (signal 'invalid-slot-type (list :group cg))))
- customg)
+ ;; The customgroup better be a list of symbols.
+ (dolist (cg customg)
+ (unless (symbolp cg)
+ (signal 'invalid-slot-type (list :group cg))))
;; First up, add this slot into our new class.
- (eieio--add-new-slot newc name init docstr type custom label customg printer
- prot initarg alloc 'defaultoverride skip-nil)
+ (eieio--add-new-slot
+ newc (cl--make-slot-descriptor
+ name init type
+ `(,@(if docstr `((:documentation . ,docstr)))
+ ,@(if custom `((:custom . ,custom)))
+ ,@(if label `((:label . ,label)))
+ ,@(if customg `((:group . ,customg)))
+ ,@(if printer `((:printer . ,printer)))
+ ,@(if prot `((:protection . ,prot)))))
+ initarg alloc 'defaultoverride skip-nil)
;; We need to id the group, and store them in a group list attribute.
(dolist (cg customg)
- (cl-pushnew cg groups :test 'equal))
+ (cl-pushnew cg groups :test #'equal))
))
;; Now that everything has been loaded up, all our lists are backwards!
- ;; Fix that up now.
- (cl-callf nreverse (eieio--class-public-a newc))
- (cl-callf nreverse (eieio--class-public-d newc))
- (cl-callf nreverse (eieio--class-public-doc newc))
- (cl-callf (lambda (types) (apply #'vector (nreverse types)))
- (eieio--class-public-type newc))
- (cl-callf nreverse (eieio--class-public-custom newc))
- (cl-callf nreverse (eieio--class-public-custom-label newc))
- (cl-callf nreverse (eieio--class-public-custom-group newc))
- (cl-callf nreverse (eieio--class-public-printer newc))
- (cl-callf nreverse (eieio--class-protection newc))
+ ;; Fix that up now and then them into vectors.
+ (cl-callf (lambda (slots) (apply #'vector (nreverse slots)))
+ (eieio--class-slots newc))
(cl-callf nreverse (eieio--class-initarg-tuples newc))
;; The storage for class-class-allocation-type needs to be turned into
;; a vector now.
- (cl-callf (lambda (cat) (apply #'vector cat))
- (eieio--class-class-allocation-type newc))
-
- ;; Also, take class allocated values, and vectorize them for speed.
- (cl-callf (lambda (cavs) (apply #'vector cavs))
- (eieio--class-class-allocation-values newc))
+ (cl-callf (lambda (slots) (apply #'vector slots))
+ (eieio--class-class-slots newc))
+
+ ;; Also, setup the class allocated values.
+ (let* ((slots (eieio--class-class-slots newc))
+ (n (length slots))
+ (v (make-vector n nil)))
+ (dotimes (i n)
+ (setf (aref v i) (eieio-default-eval-maybe
+ (cl--slot-descriptor-initform (aref slots i)))))
+ (setf (eieio--class-class-allocation-values newc) v))
;; Attach slot symbols into a hashtable, and store the index of
;; this slot as the value this table.
- (let* ((cnt 0)
+ (let* ((slots (eieio--class-slots newc))
+ ;; (cslots (eieio--class-class-slots newc))
(oa (make-hash-table :test #'eq)))
- (dolist (pubsym (eieio--class-public-a newc))
- (setf (gethash pubsym oa) cnt)
- (setq cnt (1+ cnt)))
- (setf (eieio--class-symbol-hashtable newc) oa))
+ ;; (dotimes (cnt (length cslots))
+ ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt)))
+ (dotimes (cnt (length slots))
+ (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt))
+ (setf (eieio--class-index-table newc) oa))
;; Set up a specialized doc string.
;; Use stored value since it is calculated in a non-trivial way
- (put cname 'variable-documentation
- (eieio--class-option-assoc options :documentation))
+ (let ((docstring (eieio--class-option-assoc options :documentation)))
+ (setf (eieio--class-docstring newc) docstring)
+ (when eieio-backward-compatibility
+ (put cname 'variable-documentation docstring)))
;; Save the file location where this class is defined.
(add-to-list 'current-load-list `(eieio-defclass . ,cname))
;; if this is a superclass, clear out parent (which was set to the
;; default superclass eieio-default-superclass)
- (if clearparent (setf (eieio--class-parent newc) nil))
+ (if clearparent (setf (eieio--class-parents newc) nil))
;; Create the cached default object.
- (let ((cache (make-vector (+ (length (eieio--class-public-a newc))
+ (let ((cache (make-vector (+ (length (eieio--class-slots newc))
(eval-when-compile eieio--object-num-slots))
nil))
;; We don't strictly speaking need to use a symbol, but the old
"Whether the default value VAL should be evaluated for use."
(and (consp val) (symbolp (car val)) (fboundp (car val))))
-(defun eieio--perform-slot-validation-for-default (slot spec value skipnil)
- "For SLOT, signal if SPEC does not match VALUE.
-If SKIPNIL is non-nil, then if VALUE is nil return t instead."
- (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
- eieio-skip-typecheck
- (and skipnil (null value))
- (eieio--perform-slot-validation spec value)))
- (signal 'invalid-slot-type (list slot spec value))))
-
-(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc
+(defun eieio--perform-slot-validation-for-default (slot skipnil)
+ "For SLOT, signal if its type does not match its default value.
+If SKIPNIL is non-nil, then if default value is nil return t instead."
+ (let ((value (cl--slot-descriptor-initform slot))
+ (spec (cl--slot-descriptor-type slot)))
+ (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
+ eieio-skip-typecheck
+ (and skipnil (null value))
+ (eieio--perform-slot-validation spec value)))
+ (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value)))))
+
+(defun eieio--slot-override (old new skipnil)
+ (cl-assert (eq (cl--slot-descriptor-name old) (cl--slot-descriptor-name new)))
+ ;; There is a match, and we must override the old value.
+ (let* ((a (cl--slot-descriptor-name old))
+ (tp (cl--slot-descriptor-type old))
+ (d (cl--slot-descriptor-initform new))
+ (type (cl--slot-descriptor-type new))
+ (oprops (cl--slot-descriptor-props old))
+ (nprops (cl--slot-descriptor-props new))
+ (custg (alist-get :group nprops)))
+ ;; If type is passed in, is it the same?
+ (if (not (eq type t))
+ (if (not (equal type tp))
+ (error
+ "Child slot type `%s' does not match inherited type `%s' for `%s'"
+ type tp a))
+ (setf (cl--slot-descriptor-type new) tp))
+ ;; If we have a repeat, only update the initarg...
+ (unless (eq d eieio-unbound)
+ (eieio--perform-slot-validation-for-default new skipnil)
+ (setf (cl--slot-descriptor-initform old) d))
+
+ ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
+ ;; checked and SHOULD match the superclass
+ ;; protection. Otherwise an error is thrown. However
+ ;; I wonder if a more flexible schedule might be
+ ;; implemented.
+ ;;
+ ;; EML - We used to have (if prot... here,
+ ;; but a prot of 'nil means public.
+ ;;
+ (let ((super-prot (alist-get :protection oprops))
+ (prot (alist-get :protection nprops)))
+ (if (not (eq prot super-prot))
+ (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
+ prot super-prot a)))
+ ;; End original PLN
+
+ ;; PLN Tue Jun 26 11:57:06 2007 :
+ ;; Do a non redundant combination of ancient custom
+ ;; groups and new ones.
+ (when custg
+ (let* ((list1 (alist-get :group oprops)))
+ (dolist (elt custg)
+ (unless (memq elt list1)
+ (push elt list1)))
+ (setf (alist-get :group (cl--slot-descriptor-props old)) list1)))
+ ;; End PLN
+
+ ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is
+ ;; set, simply replaces the old one.
+ (dolist (prop '(:custom :label :documentation :printer))
+ (when (alist-get prop (cl--slot-descriptor-props new))
+ (setf (alist-get prop (cl--slot-descriptor-props old))
+ (alist-get prop (cl--slot-descriptor-props new))))
+
+ ) ))
+
+(defun eieio--add-new-slot (newc slot init alloc
&optional defaultoverride skipnil)
- "Add into NEWC attribute A.
-If A already exists in NEWC, then do nothing. If it doesn't exist,
-then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg.
+ "Add into NEWC attribute SLOT.
+If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist,
+INIT is the initarg, if any.
Argument ALLOC specifies if the slot is allocated per instance, or per class.
If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC,
we must override its value for a default.
Optional argument SKIPNIL indicates if type checking should be skipped
if default value is nil."
;; Make sure we duplicate those items that are sequences.
+ (let* ((a (cl--slot-descriptor-name slot))
+ (d (cl--slot-descriptor-initform slot))
+ (old (car (cl-member a (eieio--class-slots newc)
+ :key #'cl--slot-descriptor-name)))
+ (cold (car (cl-member a (eieio--class-class-slots newc)
+ :key #'cl--slot-descriptor-name))))
(condition-case nil
(if (sequencep d) (setq d (copy-sequence d)))
- ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work.
+ ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's
+ ;; skip it if it doesn't work.
(error nil))
- (if (sequencep type) (setq type (copy-sequence type)))
- (if (sequencep cust) (setq cust (copy-sequence cust)))
- (if (sequencep custg) (setq custg (copy-sequence custg)))
+ ;; (if (sequencep type) (setq type (copy-sequence type)))
+ ;; (if (sequencep cust) (setq cust (copy-sequence cust)))
+ ;; (if (sequencep custg) (setq custg (copy-sequence custg)))
;; To prevent override information w/out specification of storage,
;; we need to do this little hack.
- (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class))
+ (if cold (setq alloc :class))
- (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance)))
+ (if (memq alloc '(nil :instance))
;; In this case, we modify the INSTANCE version of a given slot.
-
(progn
-
- ;; Only add this element if it is so-far unique
- (if (not (member a (eieio--class-public-a newc)))
- (progn
- (eieio--perform-slot-validation-for-default a type d skipnil)
- (push a (eieio--class-public-a newc))
- (push d (eieio--class-public-d newc))
- (push doc (eieio--class-public-doc newc))
- (push type (eieio--class-public-type newc))
- (push cust (eieio--class-public-custom newc))
- (push label (eieio--class-public-custom-label newc))
- (push custg (eieio--class-public-custom-group newc))
- (push print (eieio--class-public-printer newc))
- (push prot (eieio--class-protection newc))
- (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc)))
- )
- ;; When defaultoverride is true, we are usually adding new local
- ;; attributes which must override the default value of any slot
- ;; passed in by one of the parent classes.
- (when defaultoverride
- ;; There is a match, and we must override the old value.
- (let* ((ca (eieio--class-public-a newc))
- (np (member a ca))
- (num (- (length ca) (length np)))
- (dp (if np (nthcdr num (eieio--class-public-d newc))
- nil))
- (tp (if np (nth num (eieio--class-public-type newc))))
- )
- (if (not np)
- (error "EIEIO internal error overriding default value for %s"
- a)
- ;; If type is passed in, is it the same?
- (if (not (eq type t))
- (if (not (equal type tp))
- (error
- "Child slot type `%s' does not match inherited type `%s' for `%s'"
- type tp a)))
- ;; If we have a repeat, only update the initarg...
- (unless (eq d eieio-unbound)
- (eieio--perform-slot-validation-for-default a tp d skipnil)
- (setcar dp d))
- ;; If we have a new initarg, check for it.
- (when init
- (let* ((inits (eieio--class-initarg-tuples newc))
- (inita (rassq a inits)))
- ;; Replace the CAR of the associate INITA.
- ;;(message "Initarg: %S replace %s" inita init)
- (setcar inita init)
- ))
-
- ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
- ;; checked and SHOULD match the superclass
- ;; protection. Otherwise an error is thrown. However
- ;; I wonder if a more flexible schedule might be
- ;; implemented.
- ;;
- ;; EML - We used to have (if prot... here,
- ;; but a prot of 'nil means public.
- ;;
- (let ((super-prot (nth num (eieio--class-protection newc)))
- )
- (if (not (eq prot super-prot))
- (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
- prot super-prot a)))
- ;; End original PLN
-
- ;; PLN Tue Jun 26 11:57:06 2007 :
- ;; Do a non redundant combination of ancient custom
- ;; groups and new ones.
- (when custg
- (let* ((groups
- (nthcdr num (eieio--class-public-custom-group newc)))
- (list1 (car groups))
- (list2 (if (listp custg) custg (list custg))))
- (if (< (length list1) (length list2))
- (setq list1 (prog1 list2 (setq list2 list1))))
- (dolist (elt list2)
- (unless (memq elt list1)
- (push elt list1)))
- (setcar groups list1)))
- ;; End PLN
-
- ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is
- ;; set, simply replaces the old one.
- (when cust
- ;; (message "Custom type redefined to %s" cust)
- (setcar (nthcdr num (eieio--class-public-custom newc)) cust))
-
- ;; If a new label is specified, it simply replaces
- ;; the old one.
- (when label
- ;; (message "Custom label redefined to %s" label)
- (setcar (nthcdr num (eieio--class-public-custom-label newc)) label))
- ;; End PLN
-
- ;; PLN Sat Jun 30 17:24:42 2007 : when a new
- ;; doc is specified, simply replaces the old one.
- (when doc
- ;;(message "Documentation redefined to %s" doc)
- (setcar (nthcdr num (eieio--class-public-doc newc))
- doc))
- ;; End PLN
-
- ;; If a new printer is specified, it simply replaces
- ;; the old one.
- (when print
- ;; (message "printer redefined to %s" print)
- (setcar (nthcdr num (eieio--class-public-printer newc)) print))
-
- )))
- ))
+ ;; Only add this element if it is so-far unique
+ (if (not old)
+ (progn
+ (eieio--perform-slot-validation-for-default slot skipnil)
+ (push slot (eieio--class-slots newc))
+ )
+ ;; When defaultoverride is true, we are usually adding new local
+ ;; attributes which must override the default value of any slot
+ ;; passed in by one of the parent classes.
+ (when defaultoverride
+ (eieio--slot-override old slot skipnil)))
+ (when init
+ (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc)
+ :test #'equal)))
;; CLASS ALLOCATED SLOTS
- (let ((value (eieio-default-eval-maybe d)))
- (if (not (member a (eieio--class-class-allocation-a newc)))
- (progn
- (eieio--perform-slot-validation-for-default a type value skipnil)
- ;; Here we have found a :class version of a slot. This
- ;; requires a very different approach.
- (push a (eieio--class-class-allocation-a newc))
- (push doc (eieio--class-class-allocation-doc newc))
- (push type (eieio--class-class-allocation-type newc))
- (push cust (eieio--class-class-allocation-custom newc))
- (push label (eieio--class-class-allocation-custom-label newc))
- (push custg (eieio--class-class-allocation-custom-group newc))
- (push prot (eieio--class-class-allocation-protection newc))
- ;; Default value is stored in the 'values section, since new objects
- ;; can't initialize from this element.
- (push value (eieio--class-class-allocation-values newc)))
- (when defaultoverride
- ;; There is a match, and we must override the old value.
- (let* ((ca (eieio--class-class-allocation-a newc))
- (np (member a ca))
- (num (- (length ca) (length np)))
- (dp (if np
- (nthcdr num
- (eieio--class-class-allocation-values newc))
- nil))
- (tp (if np (nth num (eieio--class-class-allocation-type newc))
- nil)))
- (if (not np)
- (error "EIEIO internal error overriding default value for %s"
- a)
- ;; If type is passed in, is it the same?
- (if (not (eq type t))
- (if (not (equal type tp))
- (error
- "Child slot type `%s' does not match inherited type `%s' for `%s'"
- type tp a)))
- ;; EML - Note: the only reason to override a class bound slot
- ;; is to change the default, so allow unbound in.
-
- ;; If we have a repeat, only update the value...
- (eieio--perform-slot-validation-for-default a tp value skipnil)
- (setcar dp value))
-
- ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
- ;; checked and SHOULD match the superclass
- ;; protection. Otherwise an error is thrown. However
- ;; I wonder if a more flexible schedule might be
- ;; implemented.
- (let ((super-prot
- (car (nthcdr num (eieio--class-class-allocation-protection newc)))))
- (if (not (eq prot super-prot))
- (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
- prot super-prot a)))
- ;; Do a non redundant combination of ancient custom groups
- ;; and new ones.
- (when custg
- (let* ((groups
- (nthcdr num (eieio--class-class-allocation-custom-group newc)))
- (list1 (car groups))
- (list2 (if (listp custg) custg (list custg))))
- (if (< (length list1) (length list2))
- (setq list1 (prog1 list2 (setq list2 list1))))
- (dolist (elt list2)
- (unless (memq elt list1)
- (push elt list1)))
- (setcar groups list1)))
-
- ;; PLN Sat Jun 30 17:24:42 2007 : when a new
- ;; doc is specified, simply replaces the old one.
- (when doc
- ;;(message "Documentation redefined to %s" doc)
- (setcar (nthcdr num (eieio--class-class-allocation-doc newc))
- doc))
- ;; End PLN
-
- ;; If a new printer is specified, it simply replaces
- ;; the old one.
- (when print
- ;; (message "printer redefined to %s" print)
- (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print))
-
- ))
- ))
- ))
+ (if (not cold)
+ (progn
+ (eieio--perform-slot-validation-for-default slot skipnil)
+ ;; Here we have found a :class version of a slot. This
+ ;; requires a very different approach.
+ (push slot (eieio--class-class-slots newc)))
+ (when defaultoverride
+ ;; There is a match, and we must override the old value.
+ (eieio--slot-override cold slot skipnil))))))
(defun eieio-copy-parents-into-subclass (newc)
"Copy into NEWC the slots of PARENTS.
the new child class."
(let ((sn (eieio--class-option-assoc (eieio--class-options newc)
:allow-nil-initform)))
- (dolist (pcv (eieio--class-parent newc))
+ (dolist (pcv (eieio--class-parents newc))
;; First, duplicate all the slots of the parent.
- (let ((pa (eieio--class-public-a pcv))
- (pd (eieio--class-public-d pcv))
- (pdoc (eieio--class-public-doc pcv))
- (ptype (eieio--class-public-type pcv))
- (pcust (eieio--class-public-custom pcv))
- (plabel (eieio--class-public-custom-label pcv))
- (pcustg (eieio--class-public-custom-group pcv))
- (printer (eieio--class-public-printer pcv))
- (pprot (eieio--class-protection pcv))
- (pinit (eieio--class-initarg-tuples pcv))
- (i 0))
- (while pa
- (eieio--add-new-slot newc
- (car pa) (car pd) (car pdoc) (aref ptype i)
- (car pcust) (car plabel) (car pcustg)
- (car printer)
- (car pprot) (car-safe (car pinit)) nil nil sn)
+ (let ((pslots (eieio--class-slots pcv))
+ (pinit (eieio--class-initarg-tuples pcv)))
+ (dotimes (i (length pslots))
+ (eieio--add-new-slot newc (cl--copy-slot-descriptor (aref pslots i))
+ (car-safe (car pinit)) nil nil sn)
;; Increment each value.
- (setq pa (cdr pa)
- pd (cdr pd)
- pdoc (cdr pdoc)
- i (1+ i)
- pcust (cdr pcust)
- plabel (cdr plabel)
- pcustg (cdr pcustg)
- printer (cdr printer)
- pprot (cdr pprot)
- pinit (cdr pinit))
+ (setq pinit (cdr pinit))
)) ;; while/let
;; Now duplicate all the class alloc slots.
- (let ((pa (eieio--class-class-allocation-a pcv))
- (pdoc (eieio--class-class-allocation-doc pcv))
- (ptype (eieio--class-class-allocation-type pcv))
- (pcust (eieio--class-class-allocation-custom pcv))
- (plabel (eieio--class-class-allocation-custom-label pcv))
- (pcustg (eieio--class-class-allocation-custom-group pcv))
- (printer (eieio--class-class-allocation-printer pcv))
- (pprot (eieio--class-class-allocation-protection pcv))
- (pval (eieio--class-class-allocation-values pcv))
- (i 0))
- (while pa
- (eieio--add-new-slot newc
- (car pa) (aref pval i) (car pdoc) (aref ptype i)
- (car pcust) (car plabel) (car pcustg)
- (car printer)
- (car pprot) nil :class sn)
- ;; Increment each value.
- (setq pa (cdr pa)
- pdoc (cdr pdoc)
- pcust (cdr pcust)
- plabel (cdr plabel)
- pcustg (cdr pcustg)
- printer (cdr printer)
- pprot (cdr pprot)
- i (1+ i))
+ (let ((pcslots (eieio--class-class-slots pcv)))
+ (dotimes (i (length pcslots))
+ (eieio--add-new-slot newc (cl--copy-slot-descriptor
+ (aref pcslots i))
+ nil :class sn)
)))))
\f
nil
;; Trim off object IDX junk added in for the object index.
(setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
- (let ((st (aref (eieio--class-public-type class) slot-idx)))
+ (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class)
+ slot-idx))))
(if (not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type
- (list (eieio--class-symbol class) slot st value))))))
+ (list (eieio--class-name class) slot st value))))))
(defun eieio--validate-class-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
an error."
(if eieio-skip-typecheck
nil
- (let ((st (aref (eieio--class-class-allocation-type class)
- slot-idx)))
+ (let ((st (cl--slot-descriptor-type (aref (eieio--class-class-slots class)
+ slot-idx))))
(if (not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type
- (list (eieio--class-symbol class) slot st value))))))
+ (list (eieio--class-name class) slot st value))))))
(defun eieio-barf-if-slot-unbound (value instance slotname fn)
"Throw a signal if VALUE is a representation of an UNBOUND slot.
slot. If the slot is ok, return VALUE.
Argument FN is the function calling this verifier."
(if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
- (slot-unbound instance (eieio--object-class-object instance) slotname fn)
+ (slot-unbound instance (eieio--object-class instance) slotname fn)
value))
\f
(let ((c (eieio--class-v obj)))
(if (eieio--class-p c) (eieio-class-un-autoload obj))
c))
- (t (eieio--object-class-object obj))))
+ (t (eieio--object-class obj))))
(c (eieio--slot-name-index class slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
(cl-check-type obj (or eieio-object class))
(cl-check-type slot symbol)
(let* ((cl (cond ((symbolp obj) (eieio--class-v obj))
- (t (eieio--object-class-object obj))))
+ (t (eieio--object-class obj))))
(c (eieio--slot-name-index cl slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
;;(signal 'invalid-slot-name (list (class-name cl) slot))
)
(eieio-barf-if-slot-unbound
- (let ((val (nth (- c (eval-when-compile eieio--object-num-slots))
- (eieio--class-public-d cl))))
+ (let ((val (cl--slot-descriptor-initform
+ (aref (eieio--class-slots cl)
+ (- c (eval-when-compile eieio--object-num-slots))))))
(eieio-default-eval-maybe val))
- obj (eieio--class-symbol cl) 'oref-default))))
+ obj (eieio--class-name cl) 'oref-default))))
(defun eieio-default-eval-maybe (val)
"Check VAL, and return what `oref-default' would provide."
Fills in OBJ's SLOT with VALUE."
(cl-check-type obj eieio-object)
(cl-check-type slot symbol)
- (let* ((class (eieio--object-class-object obj))
+ (let* ((class (eieio--object-class obj))
(c (eieio--slot-name-index class slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
(eieio--validate-class-slot-value class c value slot)
(aset (eieio--class-class-allocation-values class) c
value))
- (signal 'invalid-slot-name (list (eieio--class-symbol class) slot)))
+ (signal 'invalid-slot-name (list (eieio--class-name class) slot)))
+ ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
+ ;; not by CLOS and is mildly inconsistent with the :initform thingy, so
+ ;; it'd be nice to get of it. This said, it is/was used at one place by
+ ;; gnus/registry.el, so it might be used elsewhere as well, so let's
+ ;; keep it for now.
+ ;; FIXME: Generate a compile-time warning for it!
+ ;; (error "Can't `oset-default' an instance-allocated slot: %S of %S"
+ ;; slot class)
(eieio--validate-slot-value class c value slot)
;; Set this into the storage for defaults.
(if (eieio-eval-default-p value)
(error "Can't set default to a sexp that gets evaluated again"))
- (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
- (eieio--class-public-d class))
+ (setf (cl--slot-descriptor-initform
+ ;; FIXME: Apparently we set it both in `slots' and in
+ ;; `object-cache', which seems redundant.
+ (aref (eieio--class-slots class)
+ (- c (eval-when-compile eieio--object-num-slots))))
value)
;; Take the value, and put it into our cache object.
(eieio-oset (eieio--class-default-object-cache class)
If SLOT is the value created with :initarg instead,
reverse-lookup that name, and recurse with the associated slot value."
;; Removed checks to outside this call
- (let* ((fsi (gethash slot (eieio--class-symbol-hashtable class))))
+ (let* ((fsi (gethash slot (eieio--class-index-table class))))
(if (integerp fsi)
(+ (eval-when-compile eieio--object-num-slots) fsi)
(let ((fn (eieio--initarg-to-attribute class slot)))
- (if fn (eieio--slot-name-index class fn) nil)))))
+ (if fn
+ ;; Accessing a slot via its :initarg is accepted by EIEIO
+ ;; (but not CLOS) but is a bad idea (for one: it's slower).
+ ;; FIXME: We should emit a compile-time warning when this happens!
+ (eieio--slot-name-index class fn)
+ nil)))))
(defun eieio--class-slot-name-index (class slot)
"In CLASS find the index of the named SLOT.
reverse-lookup that name, and recurse with the associated slot value."
;; This will happen less often, and with fewer slots. Do this the
;; storage cheap way.
- (let* ((a (eieio--class-class-allocation-a class))
- (l1 (length a))
- (af (memq slot a))
- (l2 (length af)))
- ;; Slot # is length of the total list, minus the remaining list of
- ;; the found slot.
- (if af (- l1 l2))))
+ (let ((index nil)
+ (slots (eieio--class-class-slots class)))
+ (dotimes (i (length slots))
+ (if (eq slot (cl--slot-descriptor-name (aref slots i)))
+ (setq index i)))
+ index))
;;;
;; Way to assign slots based on a list. Used for constructors, or
If SET-ALL is non-nil, then when a default is nil, that value is
reset. If SET-ALL is nil, the slots are only reset if the default is
not nil."
- (let ((pub (eieio--class-public-a (eieio--object-class-object obj))))
- (while pub
- (let ((df (eieio-oref-default obj (car pub))))
+ (let ((slots (eieio--class-slots (eieio--object-class obj))))
+ (dotimes (i (length slots))
+ (let* ((name (cl--slot-descriptor-name (aref slots i)))
+ (df (eieio-oref-default obj name)))
(if (or df set-all)
- (eieio-oset obj (car pub) df)))
- (setq pub (cdr pub)))))
+ (eieio-oset obj name df))))))
(defun eieio--initarg-to-attribute (class initarg)
"For CLASS, convert INITARG to the actual attribute name.
(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
"Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
If a consistent order does not exist, signal an error."
- (if (let ((tail remaining-inputs)
- (found nil))
- (while (and tail (not found))
- (setq found (car tail) tail (cdr tail)))
- (not found))
+ (setq remaining-inputs (delq nil remaining-inputs))
+ (if (null remaining-inputs)
;; If all remaining inputs are empty lists, we are done.
(nreverse reversed-partial-result)
;; Otherwise, we try to find the next element of the result. This
(tail remaining-inputs)
(next (progn
(while (and tail (not found))
- (setq found (and (car tail)
- (eieio--c3-candidate (caar tail)
- remaining-inputs))
+ (setq found (eieio--c3-candidate (caar tail)
+ remaining-inputs)
tail (cdr tail)))
found)))
(if next
;; The graph is inconsistent, give up
(signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
+(defsubst eieio--class/struct-parents (class)
+ (or (eieio--class-parents class)
+ `(,eieio-default-superclass)))
+
(defun eieio--class-precedence-c3 (class)
"Return all parents of CLASS in c3 order."
- (let ((parents (eieio--class-parent (eieio--class-v class))))
+ (let ((parents (eieio--class-parents (eieio--class-v class))))
(eieio--c3-merge-lists
(list class)
(append
(defun eieio--class-precedence-dfs (class)
"Return all parents of CLASS in depth-first order."
- (let* ((parents (eieio--class-parent class))
+ (let* ((parents (eieio--class-parents class))
(classes (copy-sequence
(apply #'append
(list class)
(defun eieio--class-precedence-bfs (class)
"Return all parents of CLASS in breadth-first order."
(let* ((result)
- (queue (or (eieio--class-parent class)
- `(,eieio-default-superclass))))
+ (queue (eieio--class/struct-parents class)))
(while queue
(let ((head (pop queue)))
(unless (member head result)
(push head result)
(unless (eq head eieio-default-superclass)
- (setq queue (append queue (or (eieio--class-parent head)
- `(,eieio-default-superclass))))))))
+ (setq queue (append queue (eieio--class/struct-parents head)))))))
(cons class (nreverse result)))
)
(if (or (null class) (eq class eieio-default-superclass))
nil
(unless (eieio--class-default-object-cache class)
- (eieio-class-un-autoload (eieio--class-symbol class)))
+ (eieio-class-un-autoload (eieio--class-name class)))
(cl-case (eieio--class-method-invocation-order class)
(:depth-first
(eieio--class-precedence-dfs class))
50 #'cl--generic-struct-tag
(lambda (tag)
(and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
- (mapcar #'eieio--class-symbol
+ (mapcar #'eieio--class-name
(eieio--class-precedence-list (symbol-value tag)))))))
(cl-defmethod cl-generic-generalizers :extra "class" (specializer)
(defun eieio--generic-subclass-specializers (tag)
(when (eieio--class-p tag)
(mapcar (lambda (class)
- `(subclass ,(eieio--class-symbol class)))
+ `(subclass ,(eieio--class-name class)))
(eieio--class-precedence-list tag))))
(defconst eieio--generic-subclass-generalizer
(list eieio--generic-subclass-generalizer))
\f
-;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "25a66814a400e7dea16bf0f3bfe245ed")
+;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "0609a7bdcd6f38876b7f5647047ddca9")
;;; Generated autoloads from eieio-compat.el
(autoload 'eieio--defalias "eieio-compat" "\
(let* ((chil nil)
(obj (widget-get widget :value))
(master-group (widget-get widget :eieio-group))
- (cv (eieio--object-class-object obj))
- (slots (eieio--class-public-a cv))
- (flabel (eieio--class-public-custom-label cv))
- (fgroup (eieio--class-public-custom-group cv))
- (fdoc (eieio--class-public-doc cv))
- (fcust (eieio--class-public-custom cv)))
+ (cv (eieio--object-class obj))
+ (slots (eieio--class-slots cv)))
;; First line describes the object, but may not editable.
(if (widget-get widget :eieio-show-name)
(setq chil (cons (widget-create-child-and-convert
chil)))
;; Display information about the group being shown
(when master-group
- (let ((groups (eieio--class-option (eieio--object-class-object obj)
+ (let ((groups (eieio--class-option (eieio--object-class obj)
:custom-groups)))
(widget-insert "Groups:")
(while groups
(setq groups (cdr groups)))
(widget-insert "\n\n")))
;; Loop over all the slots, creating child widgets.
- (while slots
- ;; Output this slot if it has a customize flag associated with it.
- (when (and (car fcust)
- (or (not master-group) (member master-group (car fgroup)))
- (slot-boundp obj (car slots)))
- ;; In this case, this slot has a custom type. Create its
- ;; children widgets.
- (let ((type (eieio-filter-slot-type widget (car fcust)))
- (stuff nil))
- ;; This next bit is an evil hack to get some EDE functions
- ;; working the way I like.
- (if (and (listp type)
- (setq stuff (member :slotofchoices type)))
- (let ((choices (eieio-oref obj (car (cdr stuff))))
- (newtype nil))
- (while (not (eq (car type) :slotofchoices))
- (setq newtype (cons (car type) newtype)
- type (cdr type)))
- (while choices
- (setq newtype (cons (list 'const (car choices))
- newtype)
- choices (cdr choices)))
- (setq type (nreverse newtype))))
- (setq chil (cons (widget-create-child-and-convert
- widget 'object-slot
- :childtype type
- :sample-face 'eieio-custom-slot-tag-face
- :tag
- (concat
- (make-string
- (or (widget-get widget :indent) 0)
- ? )
- (if (car flabel)
- (car flabel)
- (let ((s (symbol-name
- (or
- (eieio--class-slot-initarg
- (eieio--object-class-object obj)
- (car slots))
- (car slots)))))
- (capitalize
- (if (string-match "^:" s)
- (substring s (match-end 0))
- s)))))
- :value (slot-value obj (car slots))
- :doc (if (car fdoc) (car fdoc)
- "Slot not Documented.")
- :eieio-custom-visibility 'visible
- )
- chil))
- )
- )
- (setq slots (cdr slots)
- fdoc (cdr fdoc)
- fcust (cdr fcust)
- flabel (cdr flabel)
- fgroup (cdr fgroup)))
+ (dotimes (i (length slots))
+ (let* ((slot (aref slots i))
+ (props (cl--slot-descriptor-props slot)))
+ ;; Output this slot if it has a customize flag associated with it.
+ (when (and (alist-get :custom props)
+ (or (not master-group)
+ (member master-group (alist-get :group props)))
+ (slot-boundp obj (cl--slot-descriptor-name slot)))
+ ;; In this case, this slot has a custom type. Create its
+ ;; children widgets.
+ (let ((type (eieio-filter-slot-type widget (alist-get :custom props)))
+ (stuff nil))
+ ;; This next bit is an evil hack to get some EDE functions
+ ;; working the way I like.
+ (if (and (listp type)
+ (setq stuff (member :slotofchoices type)))
+ (let ((choices (eieio-oref obj (car (cdr stuff))))
+ (newtype nil))
+ (while (not (eq (car type) :slotofchoices))
+ (setq newtype (cons (car type) newtype)
+ type (cdr type)))
+ (while choices
+ (setq newtype (cons (list 'const (car choices))
+ newtype)
+ choices (cdr choices)))
+ (setq type (nreverse newtype))))
+ (setq chil (cons (widget-create-child-and-convert
+ widget 'object-slot
+ :childtype type
+ :sample-face 'eieio-custom-slot-tag-face
+ :tag
+ (concat
+ (make-string
+ (or (widget-get widget :indent) 0)
+ ?\s)
+ (or (alist-get :label props)
+ (let ((s (symbol-name
+ (or
+ (eieio--class-slot-initarg
+ (eieio--object-class obj)
+ (car slots))
+ (car slots)))))
+ (capitalize
+ (if (string-match "^:" s)
+ (substring s (match-end 0))
+ s)))))
+ :value (slot-value obj (car slots))
+ :doc (or (alist-get :documentation props)
+ "Slot not Documented.")
+ :eieio-custom-visibility 'visible
+ )
+ chil))
+ ))))
(widget-put widget :children (nreverse chil))
))
"Get the value of WIDGET."
(let* ((obj (widget-get widget :value))
(master-group eieio-cog)
- (cv (eieio--object-class-object obj))
- (fgroup (eieio--class-public-custom-group cv))
(wids (widget-get widget :children))
(name (if (widget-get widget :eieio-show-name)
(car (widget-apply (car wids) :value-inline))
nil))
(chil (if (widget-get widget :eieio-show-name)
(nthcdr 1 wids) wids))
- (cv (eieio--object-class-object obj))
- (slots (eieio--class-public-a cv))
- (fcust (eieio--class-public-custom cv)))
+ (cv (eieio--object-class obj))
+ (i 0)
+ (slots (eieio--class-slots cv)))
;; If there are any prefix widgets, clear them.
;; -- None yet
;; Create a batch of initargs for each slot.
- (while (and slots chil)
- (if (and (car fcust)
- (or eieio-custom-ignore-eieio-co
- (not master-group) (member master-group (car fgroup)))
- (slot-boundp obj (car slots)))
- (progn
- ;; Only customized slots have widgets
- (let ((eieio-custom-ignore-eieio-co t))
- (eieio-oset obj (car slots)
- (car (widget-apply (car chil) :value-inline))))
- (setq chil (cdr chil))))
- (setq slots (cdr slots)
- fgroup (cdr fgroup)
- fcust (cdr fcust)))
+ (while (and (< i (length slots)) chil)
+ (let* ((slot (aref slots i))
+ (props (cl--slot-descriptor-props slot))
+ (cust (alist-get :custom props)))
+ (if (and cust
+ (or eieio-custom-ignore-eieio-co
+ (not master-group)
+ (member master-group (alist-get :group props)))
+ (slot-boundp obj (cl--slot-descriptor-name slot)))
+ (progn
+ ;; Only customized slots have widgets
+ (let ((eieio-custom-ignore-eieio-co t))
+ (eieio-oset obj (cl--slot-descriptor-name slot)
+ (car (widget-apply (car chil) :value-inline))))
+ (setq chil (cdr chil))))))
;; Set any name updates on it.
(if name (eieio-object-set-name-string obj name))
;; This is the same object we had before.
(vector (concat "Group " (symbol-name group))
(list 'customize-object obj (list 'quote group))
t))
- (eieio--class-option (eieio--object-class-object obj) :custom-groups)))
+ (eieio--class-option (eieio--object-class obj) :custom-groups)))
(defvar eieio-read-custom-group-history nil
"History for the custom group reader.")
(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)
+ (let ((g (eieio--class-option (eieio--object-class obj)
:custom-groups)))
(if (= (length g) 1)
(car g)
;;; Code:
+(declare-function data-debug/eieio-insert-slots "eieio-datadebug"
+ (obj eieio-default-superclass))
+
(defun data-debug-insert-object-slots (object prefix)
"Insert all the slots of OBJECT.
PREFIX specifies what to insert at the start of each line."
"Insert a button representing OBJECT.
PREFIX is the text that precedes the button.
PREBUTTONTEXT is some text between PREFIX and the object button."
- (let ((start (point))
- (end nil)
- (str (object-print object))
- (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
- (eieio-object-name-string object)
- (eieio-object-class object)
- (eieio-class-parents (eieio-object-class object))
- (length (object-slots object))
- ))
- )
+ (let* ((start (point))
+ (end nil)
+ (str (object-print object))
+ (class (eieio-object-class object))
+ (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
+ (eieio-object-name-string object)
+ class
+ (eieio-class-parents class)
+ (length (eieio-class-slots class))
+ ))
+ )
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
;; Each object should have an opportunity to show stuff about itself.
(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
- prefix)
+ prefix)
"Insert the slots of OBJ into the current DDEBUG buffer."
(let ((inhibit-read-only t))
(data-debug-insert-thing (eieio-object-name-string obj)
prefix
"Name: ")
- (let* ((cl (eieio-object-class obj))
- (cv (eieio--class-v cl)))
- (data-debug-insert-thing (eieio--class-constructor cl)
+ (let* ((cv (eieio--object-class obj)))
+ (data-debug-insert-thing (eieio--class-name cv)
prefix
"Class: ")
;; Loop over all the public slots
- (let ((publa (eieio--class-public-a cv))
- )
- (while publa
- (if (slot-boundp obj (car publa))
- (let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
- (car publa)))
- (v (eieio-oref obj (car publa))))
- (data-debug-insert-thing
- v prefix (concat
- (if i (symbol-name i)
- (symbol-name (car publa)))
- " ")))
- ;; Unbound case
- (let ((i (eieio--class-slot-initarg (eieio--class-v cl)
- (car publa))))
- (data-debug-insert-custom
- "#unbound" prefix
- (concat (if i (symbol-name i)
- (symbol-name (car publa)))
- " ")
- 'font-lock-keyword-face))
- )
- (setq publa (cdr publa)))))))
+ (let ((slots (eieio--class-slots cv)))
+ (dotimes (i (length slots))
+ (let* ((slot (aref slots i))
+ (sname (cl--slot-descriptor-name slot))
+ (i (eieio--class-slot-initarg cv sname))
+ (sstr (concat (symbol-name (or i sname)) " ")))
+ (if (slot-boundp obj sname)
+ (let* ((v (eieio-oref obj sname)))
+ (data-debug-insert-thing v prefix sstr))
+ ;; Unbound case
+ (data-debug-insert-custom
+ "#unbound" prefix sstr
+ 'font-lock-keyword-face)
+ )))))))
;;; Augment the Data debug thing display list.
(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing))
(when pl
(insert " Inherits from ")
(while (setq cur (pop pl))
- (setq cur (eieio--class-symbol cur))
+ (setq cur (eieio--class-name cur))
(insert "`")
(help-insert-xref-button (symbol-name cur)
'help-function cur)
(or doc "")))
(insert "\n\n")))))
+(defun eieio--help-print-slot (slot)
+ (insert
+ (concat
+ (propertize "Slot: " 'face 'bold)
+ (prin1-to-string (cl--slot-descriptor-name slot))
+ (unless (eq (cl--slot-descriptor-type slot) t)
+ (concat " type = "
+ (prin1-to-string (cl--slot-descriptor-type slot))))
+ (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound)
+ (concat " default = "
+ (prin1-to-string (cl--slot-descriptor-initform slot))))
+ (when (alist-get :printer (cl--slot-descriptor-props slot))
+ (concat " printer = "
+ (prin1-to-string
+ (alist-get :printer (cl--slot-descriptor-props slot)))))
+ (when (alist-get :documentation (cl--slot-descriptor-props slot))
+ (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot))
+ "\n")))
+ "\n"))
+
(defun eieio-help-class-slots (class)
"Print help description for the slots in CLASS.
Outputs to the current buffer."
(let* ((cv (eieio--class-v class))
- (docs (eieio--class-public-doc cv))
- (names (eieio--class-public-a cv))
- (deflt (eieio--class-public-d cv))
- (types (eieio--class-public-type cv))
- (publp (eieio--class-public-printer cv))
- (i 0)
- (prot (eieio--class-protection cv))
- )
+ (slots (eieio--class-slots cv))
+ (cslots (eieio--class-class-slots cv)))
(insert (propertize "Instance Allocated Slots:\n\n"
'face 'bold))
- (while names
- (insert
- (concat
- (when (car prot)
- (propertize "Private " 'face 'bold))
- (propertize "Slot: " 'face 'bold)
- (prin1-to-string (car names))
- (unless (eq (aref types i) t)
- (concat " type = "
- (prin1-to-string (aref types i))))
- (unless (eq (car deflt) eieio-unbound)
- (concat " default = "
- (prin1-to-string (car deflt))))
- (when (car publp)
- (concat " printer = "
- (prin1-to-string (car publp))))
- (when (car docs)
- (concat "\n " (car docs) "\n"))
- "\n"))
- (setq names (cdr names)
- docs (cdr docs)
- deflt (cdr deflt)
- publp (cdr publp)
- prot (cdr prot)
- i (1+ i)))
- (setq docs (eieio--class-class-allocation-doc cv)
- names (eieio--class-class-allocation-a cv)
- types (eieio--class-class-allocation-type cv)
- i 0
- prot (eieio--class-class-allocation-protection cv))
- (when names
+ (dotimes (i (length slots))
+ (eieio--help-print-slot (aref slots i)))
+ (when (> (length cslots) 0)
(insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
- (while names
- (insert
- (concat
- (when (car prot)
- "Private ")
- "Slot: "
- (prin1-to-string (car names))
- (unless (eq (aref types i) t)
- (concat " type = "
- (prin1-to-string (aref types i))))
- (condition-case nil
- (let ((value (eieio-oref class (car names))))
- (concat " value = "
- (prin1-to-string value)))
- (error nil))
- (when (car docs)
- (concat "\n\n " (car docs) "\n"))
- "\n"))
- (setq names (cdr names)
- docs (cdr docs)
- prot (cdr prot)
- i (1+ i)))))
+ (dotimes (i (length cslots))
+ (eieio--help-print-slot (aref cslots i)))))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
"Return an alist of all currently active classes for completion purposes.
(declare (indent 2) (debug (sexp sexp def-body)))
(require 'cl-lib)
;; Transform the spec-list into a cl-symbol-macrolet spec-list.
- (let ((mappings (mapcar (lambda (entry)
- (let ((var (if (listp entry) (car entry) entry))
- (slot (if (listp entry) (cadr entry) entry)))
- (list var `(slot-value ,object ',slot))))
- spec-list)))
- (append (list 'cl-symbol-macrolet mappings)
- body)))
+ (macroexp-let2 nil object object
+ `(cl-symbol-macrolet
+ ,(mapcar (lambda (entry)
+ (let ((var (if (listp entry) (car entry) entry))
+ (slot (if (listp entry) (cadr entry) entry)))
+ (list var `(slot-value ,object ',slot))))
+ spec-list)
+ ,@body)))
\f
;;; Simple generators, and query functions. None of these would do
;; well embedded into an object.
;;
+
(define-obsolete-function-alias
- 'object-class-fast #'eieio--object-class-name "24.4")
+ 'object-class-fast #'eieio-object-class "24.4")
(cl-defgeneric eieio-object-name-string (obj)
"Return a string which is OBJ's name."
"Return a printed representation for object OBJ.
If EXTRA, include that in the string returned to represent the symbol."
(cl-check-type obj eieio-object)
- (format "#<%s %s%s>" (eieio--object-class-name obj)
+ (format "#<%s %s%s>" (eieio-object-class obj)
(eieio-object-name-string obj) (or extra "")))
(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
"Return the class struct defining OBJ."
;; FIXME: We say we return a "struct" but we return a symbol instead!
(cl-check-type obj eieio-object)
- (eieio--object-class-name obj))
+ (eieio--class-name (eieio--object-class obj)))
(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
;; CLOS name, maybe?
(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4")
(defun eieio-object-class-name (obj)
"Return a Lisp like symbol name for OBJ's class."
(cl-check-type obj eieio-object)
- (eieio-class-name (eieio--object-class-object obj)))
+ (eieio-class-name (eieio--object-class obj)))
(define-obsolete-function-alias
'object-class-name 'eieio-object-class-name "24.4")
"Return parent classes to CLASS. (overload of variable).
The CLOS function `class-direct-superclasses' is aliased to this function."
- (eieio--class-parent (eieio--class-object class)))
+ (eieio--class-parents (eieio--class-object class)))
(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
(cl-check-type obj eieio-object)
- (eq (eieio--object-class-object obj) class))
+ (eq (eieio--object-class obj) class))
(defun object-of-class-p (obj class)
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
(cl-check-type obj eieio-object)
;; class will be checked one layer down
- (child-of-class-p (eieio--object-class-object obj) class))
+ (child-of-class-p (eieio--object-class obj) class))
;; Backwards compatibility
(defalias 'obj-of-class-p 'object-of-class-p)
"Return non-nil if CHILD class is a subclass of CLASS."
(setq child (eieio--class-object child))
(cl-check-type child eieio--class)
- ;; `eieio-default-superclass' is never mentioned in eieio--class-parent,
+ ;; `eieio-default-superclass' is never mentioned in eieio--class-parents,
;; so we have to special case it here.
(or (eq class 'eieio-default-superclass)
(let ((p nil))
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
(while (and child (not (eq child class)))
- (setq p (append p (eieio--class-parent child))
+ (setq p (append p (eieio--class-parents child))
child (pop p)))
(if child t))))
-(defun eieio-slot-descriptor-name (slot) slot)
+(defun eieio-slot-descriptor-name (slot)
+ (cl--slot-descriptor-name slot))
(defun eieio-class-slots (class)
"Return list of slots available in instances of CLASS."
;; FIXME: This only gives the instance slots and ignores the
;; class-allocated slots.
- ;; FIXME: It only gives the slot's *names* rather than actual
- ;; slot descriptors.
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
- (eieio--class-public-a class))
+ (mapcar #'identity (eieio--class-slots class)))
(defun object-slots (obj)
"Return list of slots available in OBJ."
(declare (obsolete eieio-class-slots "25.1"))
(cl-check-type obj eieio-object)
- (eieio-class-slots (eieio--object-class-object obj)))
+ (eieio-class-slots (eieio--object-class obj)))
-(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
+(defun eieio--class-slot-initarg (class slot)
+ "Fetch from CLASS, SLOT's :initarg."
(cl-check-type class eieio--class)
(let ((ia (eieio--class-initarg-tuples class))
(f nil))
(defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT."
(let ((cv (cond ((eieio-object-p object-or-class)
- (eieio--object-class-object object-or-class))
+ (eieio--object-class object-or-class))
((eieio--class-p object-or-class) object-or-class)
(t (find-class object-or-class 'error)))))
- (or (memq slot (eieio--class-public-a cv))
- (memq slot (eieio--class-class-allocation-a cv)))
- ))
+ (or (gethash slot (eieio--class-index-table cv))
+ ;; FIXME: We could speed this up by adding class slots into the
+ ;; index-table (e.g. with a negative index?).
+ (let ((cs (eieio--class-class-slots cv))
+ found)
+ (dotimes (i (length cs))
+ (if (eq slot (cl--slot-descriptor-name (aref cs i)))
+ (setq found t)))
+ found))))
(defun find-class (symbol &optional errorp)
"Return the class that SYMBOL represents.
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine."
(while slots
- (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
+ (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj)
(car slots))))
(if (not rn)
(slot-missing obj (car slots) 'oset (car (cdr slots)))
dynamically set from SLOTS."
;; First, see if any of our defaults are `lambda', and
;; re-evaluate them and apply the value to our slots.
- (let* ((this-class (eieio--object-class-object this))
- (defaults (eieio--class-public-d this-class)))
- (dolist (slot (eieio--class-public-a this-class))
+ (let* ((this-class (eieio--object-class this))
+ (slots (eieio--class-slots this-class)))
+ (dotimes (i (length slots))
;; For each slot, see if we need to evaluate it.
;;
;; Paul Landes said in an email:
;; > the quoted thing as you already have. This is by the
;; > Sonya E. Keene book and other things I've look at on the
;; > web.
- (let ((dflt (eieio-default-eval-maybe (car defaults))))
- (when (not (eq dflt (car defaults)))
- (eieio-oset this slot dflt) ))
- ;; Next.
- (setq defaults (cdr defaults))))
+ (let* ((slot (aref slots i))
+ (initform (cl--slot-descriptor-initform slot))
+ (dflt (eieio-default-eval-maybe initform)))
+ (when (not (eq dflt initform))
+ ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)!
+ (eieio-oset this (cl--slot-descriptor-name slot) dflt)))))
;; Shared initialize will parse our slots for us.
(shared-initialize this slots))
(prin1 (eieio-object-name-string this))
(princ "\n")
;; Loop over all the public slots
- (let ((publa (eieio--class-public-a cv))
- (publd (eieio--class-public-d cv))
- (publp (eieio--class-public-printer cv))
+ (let ((slots (eieio--class-slots cv))
(eieio-print-depth (1+ eieio-print-depth)))
- (while publa
- (when (slot-boundp this (car publa))
- (let ((i (eieio--class-slot-initarg cv (car publa)))
- (v (eieio-oref this (car publa)))
- )
- (unless (or (not i) (equal v (car publd)))
- (unless (bolp)
- (princ "\n"))
- (princ (make-string (* eieio-print-depth 2) ? ))
- (princ (symbol-name i))
- (if (car publp)
- ;; Use our public printer
- (progn
- (princ " ")
- (funcall (car publp) v))
- ;; Use our generic override prin1 function.
- (princ (if (or (eieio-object-p v)
- (eieio-object-p (car-safe v)))
- "\n" " "))
- (eieio-override-prin1 v)))))
- (setq publa (cdr publa) publd (cdr publd)
- publp (cdr publp))))
+ (dotimes (i (length slots))
+ (let ((slot (aref slots i)))
+ (when (slot-boundp this (cl--slot-descriptor-name slot))
+ (let ((i (eieio--class-slot-initarg
+ cv (cl--slot-descriptor-name slot)))
+ (v (eieio-oref this (cl--slot-descriptor-name slot))))
+ (unless (or (not i) (equal v (cl--slot-descriptor-initform slot)))
+ (unless (bolp)
+ (princ "\n"))
+ (princ (make-string (* eieio-print-depth 2) ? ))
+ (princ (symbol-name i))
+ (if (alist-get :printer (cl--slot-descriptor-props slot))
+ ;; Use our public printer
+ (progn
+ (princ " ")
+ (funcall (alist-get :printer
+ (cl--slot-descriptor-props slot))
+ v))
+ ;; Use our generic override prin1 function.
+ (princ (if (or (eieio-object-p v)
+ (eieio-object-p (car-safe v)))
+ "\n" " "))
+ (eieio-override-prin1 v))))))))
(princ ")")
(when (= eieio-print-depth 0)
(princ "\n"))))
\f
;;; Start of automatically extracted autoloads.
\f
-;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2ec91e473fcad1ff20cd76edc4aab706")
+;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "813d32fbf76d4248fc6b4dc97ebcd720")
;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\
;;;***
\f
-;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d1910eb455f102989fc33bb3f5a9b614")
+;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "3005b815c6b30eccbf0642170b3f82a5")
;;; Generated autoloads from eieio-opt.el
(autoload 'eieio-browse "eieio-opt" "\
+2015-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * automated/eieio-tests.el (eieio-test-17-virtual-slot): Don't use
+ initarg in `oset'.
+ (eieio-test-32-slot-attribute-override-2): Adjust to new
+ slot representation.
+
+ * automated/eieio-test-persist.el (persist-test-save-and-compare):
+ Adjust to new slot representation.
+
+ * automated/eieio-test-methodinvoke.el (make-instance): Use new-style
+ `subclass' specializer for a change.
+
2015-03-17 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/cl-lib-tests.el: Use lexical-binding.
(if (next-method-p) (call-next-method))
)
-(defmethod make-instance :STATIC ((p C) &rest args)
+(cl-defmethod make-instance ((p (subclass C)) &rest args)
(eieio-test-method-store :STATIC 'C)
(call-next-method)
)
(eieio-persistent-save original)
- (let* ((file (oref original :file))
+ (let* ((file (oref original file))
(class (eieio-object-class original))
(fromdisk (eieio-persistent-read file class))
(cv (eieio--class-v class))
- (slot-names (eieio--class-public-a cv))
- (slot-deflt (eieio--class-public-d cv))
+ (slots (eieio--class-slots cv))
)
(unless (object-of-class-p fromdisk class)
(error "Persistent class %S != original class %S"
(eieio-object-class fromdisk)
class))
- (while slot-names
- (let* ((oneslot (car slot-names))
+ (dotimes (i (length slots))
+ (let* ((slot (aref slots i))
+ (oneslot (cl--slot-descriptor-name slot))
(origvalue (eieio-oref original oneslot))
(fromdiskvalue (eieio-oref fromdisk oneslot))
(initarg-p (eieio--attribute-to-initarg
(error "Slot %S Original Val %S != Persistent Val %S"
oneslot origvalue fromdiskvalue))
;; Else !initarg-p
- (unless (equal (car slot-deflt) fromdiskvalue)
+ (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue)
(error "Slot %S Persistent Val %S != Default Value %S"
- oneslot fromdiskvalue (car slot-deflt))))
-
- (setq slot-names (cdr slot-names)
- slot-deflt (cdr slot-deflt))
+ oneslot fromdiskvalue (cl--slot-descriptor-initform slot))))
))))
;;; Simple Case
(ert-deftest eieio-test-17-virtual-slot ()
(setq eitest-vsca (virtual-slot-class :base-value 1))
;; Check slot values
- (should (= (oref eitest-vsca :base-value) 1))
+ (should (= (oref eitest-vsca base-value) 1))
(should (= (oref eitest-vsca :derived-value) 2))
- (oset eitest-vsca :derived-value 3)
- (should (= (oref eitest-vsca :base-value) 2))
+ (oset eitest-vsca derived-value 3)
+ (should (= (oref eitest-vsca base-value) 2))
(should (= (oref eitest-vsca :derived-value) 3))
- (oset eitest-vsca :base-value 3)
- (should (= (oref eitest-vsca :base-value) 3))
+ (oset eitest-vsca base-value 3)
+ (should (= (oref eitest-vsca base-value) 3))
(should (= (oref eitest-vsca :derived-value) 4))
;; should also be possible to initialize instance using virtual slot
(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)))
(ert-deftest eieio-test-18-slot-unbound ()
(setq eitest-t1 (class-c))
;; Slot initialization
(should (eq (oref eitest-t1 slot-1) 'moose))
- (should (eq (oref eitest-t1 :moose) 'moose))
+ ;; Accessing via the initarg name is deprecated!
+ ;; (should (eq (oref eitest-t1 :moose) 'moose))
;; Don't pass reference of private slot
;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
;; Check private slot accessor
;; See previous test, nor for subclass
(setq eitest-t2 (class-subc))
(should (eq (oref eitest-t2 slot-1) 'moose))
- (should (eq (oref eitest-t2 :moose) 'moose))
+ ;; Accessing via the initarg name is deprecated!
+ ;;(should (eq (oref eitest-t2 :moose) 'moose))
(should (string= (get-slot-2 eitest-t2) "linux"))
;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
(should (string= (get-slot-2 eitest-t2) "linux"))
(ert-deftest eieio-test-32-slot-attribute-override-2 ()
(let* ((cv (eieio--class-v 'slotattr-ok))
- (docs (eieio--class-public-doc cv))
- (names (eieio--class-public-a cv))
- (cust (eieio--class-public-custom cv))
- (label (eieio--class-public-custom-label cv))
- (group (eieio--class-public-custom-group cv))
- (types (eieio--class-public-type cv))
- (args (eieio--class-initarg-tuples cv))
- (i 0))
+ (slots (eieio--class-slots cv))
+ (args (eieio--class-initarg-tuples cv)))
;; :initarg should override for subclass
(should (assoc :initblarg args))
- (while (< i (length names))
- (cond
- ((eq (nth i names) 'custom)
- ;; Custom slot attributes must override
- (should (eq (nth i cust) 'string))
- ;; Custom label slot attribute must override
- (should (string= (nth i label) "One String"))
- (let ((grp (nth i group)))
- ;; Custom group slot attribute must combine
- (should (and (memq 'moose grp) (memq 'cow grp)))))
- (t nil))
-
- (setq i (1+ i)))))
+ (dotimes (i (length slots))
+ (let* ((slot (aref slots i))
+ (props (cl--slot-descriptor-props slot)))
+ (cond
+ ((eq (cl--slot-descriptor-name slot) 'custom)
+ ;; Custom slot attributes must override
+ (should (eq (alist-get :custom props) 'string))
+ ;; Custom label slot attribute must override
+ (should (string= (alist-get :label props) "One String"))
+ (let ((grp (alist-get :group props)))
+ ;; Custom group slot attribute must combine
+ (should (and (memq 'moose grp) (memq 'cow grp)))))
+ (t nil))))))
(defvar eitest-CLONETEST1 nil)
(defvar eitest-CLONETEST2 nil)
(should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
(should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
-(defclass eieio--testing ()
- ())
+(defclass eieio--testing () ())
(defmethod constructor :static ((_x eieio--testing) newname &rest _args)
(list newname 2))
projects / emacs.git / commitdiff