mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-25 07:28:20 +00:00
Code Issues Releases Activity

EIEIO: Change class's representation to unify instance & class slots

Browse Source 
* lisp/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.

* lisp/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.

* lisp/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.

* lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers):
Extract from eieio--generic-static-symbol-generalizer.
(eieio--generic-static-symbol-generalizer): Use it.

* lisp/emacs-lisp/eieio-custom.el (eieio-object-value-create)
(eieio-object-value-get): Adjust to new slot representation.

* lisp/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.

* lisp/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.

* test/automated/eieio-test-methodinvoke.el (make-instance): Use new-style
`subclass' specializer for a change.

* test/automated/eieio-test-persist.el (persist-test-save-and-compare):
Adjust to new slot representation.

* test/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.

* lisp/emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'.
This commit is contained in:
Stefan Monnier 2015-03-18 23:02:26 -04:00
parent f469024eea
commit 50c117fe86
13 changed files with 581 additions and 702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
lisp/ChangeLog
View File

@ -1,3 +1,57 @@
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

4
lisp/emacs-lisp/cl-preloaded.el
View File

@ -212,7 +212,9 @@
;; 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))

36
lisp/emacs-lisp/eieio-base.el
View File

@ -254,25 +254,28 @@ malicious code.
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)
)
@ -290,16 +293,11 @@ constructor functions are considered valid.
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)))

21
lisp/emacs-lisp/eieio-compat.el
View File

@ -124,19 +124,22 @@ Summary:
(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
@ -148,7 +151,7 @@ Summary:
(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))))))

628
lisp/emacs-lisp/eieio-core.el
View File

@ -85,9 +85,10 @@ Currently under control of this var:
;; 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
@ -96,30 +97,16 @@ Currently under control of this var:
;; 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
@ -142,18 +129,13 @@ Currently under control of this var:
;; 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)))
;;; Important macros used internally in eieio.
@ -189,7 +171,7 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
"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
@ -354,10 +336,10 @@ See `defclass' for more information."
(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)
@ -366,7 +348,7 @@ See `defclass' for more information."
;; 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
@ -442,62 +424,70 @@ See `defclass' for more information."
(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))
(cl-callf (lambda (slots) (apply #'vector slots))
(eieio--class-class-slots newc))
;; Also, take class allocated values, and vectorize them for speed.
(cl-callf (lambda (cavs) (apply #'vector cavs))
(eieio--class-class-allocation-values 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))
@ -514,10 +504,10 @@ See `defclass' for more information."
;; 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
@ -544,239 +534,133 @@ See `defclass' for more information."
"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--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--add-new-slot (newc a d doc type cust label custg print prot init alloc
(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.
@ -784,63 +668,22 @@ Follow the rules of not overwriting early parents when applying to
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)
)))))
@ -865,10 +708,11 @@ an error."
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.
@ -877,11 +721,11 @@ SLOT is the slot that is being checked, and is only used when throwing
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.
@ -889,7 +733,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending
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))
@ -904,7 +748,7 @@ Argument FN is the function calling this verifier."
(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.
@ -928,7 +772,7 @@ Fills in OBJ's SLOT with its default value."
(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.
@ -942,10 +786,11 @@ Fills in OBJ's SLOT with its default value."
;;(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."
@ -966,7 +811,7 @@ Fills in OBJ's SLOT with its default value."
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.
@ -1001,13 +846,24 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(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)
@ -1023,11 +879,16 @@ The slot is a symbol which is installed in CLASS by the `defclass' call.
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.
@ -1036,13 +897,12 @@ call. If SLOT is the value created with :initarg instead,
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
@ -1053,12 +913,12 @@ reverse-lookup that name, and recurse with the associated slot value."
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.
@ -1085,11 +945,8 @@ need be... May remove that later...)"
(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
@ -1100,9 +957,8 @@ If a consistent order does not exist, signal an error."
(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
@ -1116,9 +972,13 @@ If a consistent order does not exist, signal an error."
;; 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
@ -1132,7 +992,7 @@ If a consistent order does not exist, signal an error."
(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)
@ -1155,15 +1015,13 @@ If a consistent order does not exist, signal an error."
(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)))
)
@ -1177,7 +1035,7 @@ method invocation orders of the involved classes."
(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))
@ -1211,7 +1069,7 @@ method invocation orders of the involved classes."
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)
@ -1235,7 +1093,7 @@ method invocation orders of the involved classes."
(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
@ -1247,7 +1105,7 @@ method invocation orders of the involved classes."
(list eieio--generic-subclass-generalizer))
;;;### (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" "\

161
lisp/emacs-lisp/eieio-custom.el
View File

@ -193,12 +193,8 @@ Optional argument IGNORE is an extraneous parameter."
(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
@ -208,7 +204,7 @@ Optional argument IGNORE is an extraneous parameter."
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
@ -225,63 +221,59 @@ Optional argument IGNORE is an extraneous parameter."
(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))
))
@ -289,34 +281,33 @@ Optional argument IGNORE is an extraneous parameter."
"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.
@ -452,7 +443,7 @@ Must return the created widget."
(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.")
@ -460,7 +451,7 @@ Must return the created widget."
(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)

68
lisp/emacs-lisp/eieio-datadebug.el
View File

@ -31,6 +31,9 @@
;;; 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."
@ -54,16 +57,17 @@ 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)
@ -80,41 +84,31 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
;; 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))

90
lisp/emacs-lisp/eieio-opt.el
View File

@ -99,7 +99,7 @@ If CLASS is actually an object, then also display current values of that object.
(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)
@ -136,74 +136,40 @@ If CLASS is actually an object, then also display current values of that object.
(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.

132
lisp/emacs-lisp/eieio.el
View File

@ -320,19 +320,21 @@ variable name of the same name as the slot."
(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)))
;;; 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."
@ -342,7 +344,7 @@ variable name of the same name as the slot."
"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")
@ -370,7 +372,7 @@ If EXTRA, include that in the string returned to represent the symbol."
"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")
@ -378,7 +380,7 @@ If EXTRA, include that in the string returned to represent the symbol."
(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")
@ -386,7 +388,7 @@ If EXTRA, include that in the string returned to represent the symbol."
"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")
@ -414,13 +416,13 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
(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)
@ -428,36 +430,36 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
"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))
@ -507,12 +509,18 @@ OBJECT can be an instance or a class."
(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.
@ -671,7 +679,7 @@ Called from the constructor routine.")
"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)))
@ -694,9 +702,9 @@ not taken, then new objects of your class will not have their values
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:
@ -704,11 +712,12 @@ dynamically set from SLOTS."
;; > 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))
@ -825,32 +834,31 @@ this object."
(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"))))
@ -919,7 +927,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
;;; Start of automatically extracted autoloads.
;;;### (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" "\
@ -930,7 +938,7 @@ Optional argument GROUP is the sub-group of slots to display.
;;;***
;;;### (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" "\

13
test/ChangeLog
View File

@ -1,3 +1,16 @@
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.

2
test/automated/eieio-test-methodinvoke.el
View File

@ -184,7 +184,7 @@
(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)
)

17
test/automated/eieio-test-persist.el
View File

@ -45,20 +45,20 @@ This is usually a symbol that starts with `:'."
(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
@ -70,12 +70,9 @@ This is usually a symbol that starts with `:'."
(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

57
test/automated/eieio-tests.el
View File

@ -406,21 +406,21 @@ METHOD is the method that was attempting to be called."
(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 ()
@ -560,7 +560,8 @@ METHOD is the method that was attempting to be called."
(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
@ -580,7 +581,8 @@ METHOD is the method that was attempting to be called."
;; 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"))
@ -802,30 +804,24 @@ Subclasses to override slot attributes.")
(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)
@ -891,8 +887,7 @@ Subclasses to override slot attributes.")
(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))