aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2015-03-18 23:02:26 -0400
committerStefan Monnier2015-03-18 23:02:26 -0400
commit50c117fe86d94719807cbe08353c032779b3b910 (patch)
tree9db572083112db33d17d759a245278fa0af7b897
parentf469024eea692a163beb98a824b5cc0a4e8bcda8 (diff)
downloademacs-50c117fe86d94719807cbe08353c032779b3b910.tar.gz
emacs-50c117fe86d94719807cbe08353c032779b3b910.zip
EIEIO: Change class's representation to unify instance & class slots
* 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'.
Diffstat
-rw-r--r--lisp/ChangeLog54
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el4
-rw-r--r--lisp/emacs-lisp/eieio-base.el36
-rw-r--r--lisp/emacs-lisp/eieio-compat.el21
-rw-r--r--lisp/emacs-lisp/eieio-core.el632
-rw-r--r--lisp/emacs-lisp/eieio-custom.el161
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el68
-rw-r--r--lisp/emacs-lisp/eieio-opt.el90
-rw-r--r--lisp/emacs-lisp/eieio.el132
-rw-r--r--test/ChangeLog13
-rw-r--r--test/automated/eieio-test-methodinvoke.el2
-rw-r--r--test/automated/eieio-test-persist.el17
-rw-r--r--test/automated/eieio-tests.el57
13 files changed, 583 insertions, 704 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index e75f81ba75a..7c751f4e8e8 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,57 @@
12015-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/eieio.el (with-slots): Use macroexp-let2.
4 (object-class-fast): Change recommend replacement.
5 (eieio-object-class): Rewrite.
6 (slot-exists-p): Adjust to new slot representation.
7 (initialize-instance): Adjust to new slot representation.
8 (object-write): Adjust to new slot representation.
9
10 * emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function
11 extracted from eieio-help-class-slots.
12 (eieio-help-class-slots): Use it. Adjust to new slot representation.
13
14 * emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots):
15 Declare to silence warnings.
16 (data-debug-insert-object-button): Avoid `object-slots'.
17 (data-debug/eieio-insert-slots): Adjust to new slot representation.
18
19 * emacs-lisp/eieio-custom.el (eieio-object-value-create)
20 (eieio-object-value-get): Adjust to new slot representation.
21
22 EIEIO: Change class's representation to unify instance and class slots
23 * emacs-lisp/eieio-core.el (eieio--class): Change field names and order
24 to match those of cl--class; use cl--slot for both instance slots and
25 class slots.
26 (eieio--object-num-slots): Use cl-struct-slot-info.
27 (eieio--object-class): Rename from eieio--object-class-object.
28 (eieio--object-class-name): Remove.
29 (eieio-defclass-internal): Adjust to new slot representation.
30 Store doc in class rather than in `variable-documentation'.
31 (eieio--perform-slot-validation-for-default): Change API to take
32 a slot object.
33 (eieio--slot-override): New function.
34 (eieio--add-new-slot): Rewrite.
35 (eieio-copy-parents-into-subclass): Rewrite.
36 (eieio--validate-slot-value, eieio--validate-class-slot-value)
37 (eieio-oref-default, eieio-oset-default)
38 (eieio--class-slot-name-index, eieio-set-defaults): Adjust to new
39 slot representation.
40 (eieio--c3-merge-lists): Simplify.
41 (eieio--class/struct-parents): New function.
42 (eieio--class-precedence-bfs): Use it.
43
44 * emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers):
45 Extract from eieio--generic-static-symbol-generalizer.
46 (eieio--generic-static-symbol-generalizer): Use it.
47
48 * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
49 Manually map initargs to slot names.
50 (eieio-persistent-validate/fix-slot-value): Adjust to new
51 slot representation.
52
53 * emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'.
54
12015-03-19 Vibhav Pant <vibhavp@gmail.com> 552015-03-19 Vibhav Pant <vibhavp@gmail.com>
2 56
3 * lisp/leim/quail/hangul.el 57 * lisp/leim/quail/hangul.el
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index a18e0e57b05..ed0639b63ab 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -212,7 +212,9 @@
212 ;; Intended to be shared between defstruct and defclass. 212 ;; Intended to be shared between defstruct and defclass.
213 (name nil :type symbol) ;The type name. 213 (name nil :type symbol) ;The type name.
214 (docstring nil :type string) 214 (docstring nil :type string)
215 (parents nil :type (or cl--class (list-of cl--class))) 215 ;; For structs there can only be one parent, but when EIEIO classes inherit
216 ;; from cl--class, we'll need this to hold a list.
217 (parents nil :type (list-of cl--class))
216 (slots nil :type (vector cl-slot-descriptor)) 218 (slots nil :type (vector cl-slot-descriptor))
217 (index-table nil :type hash-table)) 219 (index-table nil :type hash-table))
218 220
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 1cc9f895f8a..5b3d9029c53 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -254,25 +254,28 @@ malicious code.
254 254
255Note: This function recurses when a slot of :type of some object is 255Note: This function recurses when a slot of :type of some object is
256identified, and needing more object creation." 256identified, and needing more object creation."
257 (let ((objclass (nth 0 inputlist)) 257 (let* ((objclass (nth 0 inputlist))
258 ;; (objname (nth 1 inputlist)) 258 ;; (objname (nth 1 inputlist))
259 (slots (nthcdr 2 inputlist)) 259 (slots (nthcdr 2 inputlist))
260 (createslots nil)) 260 (createslots nil)
261 261 (class
262 ;; If OBJCLASS is an eieio autoload object, then we need to load it. 262 (progn
263 (eieio-class-un-autoload objclass) 263 ;; If OBJCLASS is an eieio autoload object, then we need to
264 ;; load it.
265 (eieio-class-un-autoload objclass)
266 (eieio--class-object objclass))))
264 267
265 (while slots 268 (while slots
266 (let ((name (car slots)) 269 (let ((initarg (car slots))
267 (value (car (cdr slots)))) 270 (value (car (cdr slots))))
268 271
269 ;; Make sure that the value proposed for SLOT is valid. 272 ;; Make sure that the value proposed for SLOT is valid.
270 ;; In addition, strip out quotes, list functions, and update 273 ;; In addition, strip out quotes, list functions, and update
271 ;; object constructors as needed. 274 ;; object constructors as needed.
272 (setq value (eieio-persistent-validate/fix-slot-value 275 (setq value (eieio-persistent-validate/fix-slot-value
273 (eieio--class-v objclass) name value)) 276 class (eieio--initarg-to-attribute class initarg) value))
274 277
275 (push name createslots) 278 (push initarg createslots)
276 (push value createslots) 279 (push value createslots)
277 ) 280 )
278 281
@@ -290,16 +293,11 @@ constructor functions are considered valid.
290Second, any text properties will be stripped from strings." 293Second, any text properties will be stripped from strings."
291 (cond ((consp proposed-value) 294 (cond ((consp proposed-value)
292 ;; Lists with something in them need special treatment. 295 ;; Lists with something in them need special treatment.
293 (let ((slot-idx (eieio--slot-name-index class slot)) 296 (let* ((slot-idx (- (eieio--slot-name-index class slot)
294 (type nil)
295 (classtype nil))
296 (setq slot-idx (- slot-idx
297 (eval-when-compile eieio--object-num-slots))) 297 (eval-when-compile eieio--object-num-slots)))
298 (setq type (aref (eieio--class-public-type class) 298 (type (cl--slot-descriptor-type (aref (eieio--class-slots class)
299 slot-idx)) 299 slot-idx)))
300 300 (classtype (eieio-persistent-slot-type-is-class-p type)))
301 (setq classtype (eieio-persistent-slot-type-is-class-p
302 type))
303 301
304 (cond ((eq (car proposed-value) 'quote) 302 (cond ((eq (car proposed-value) 'quote)
305 (car (cdr proposed-value))) 303 (car (cdr proposed-value)))
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index ee8e731b043..0283704e033 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -124,19 +124,22 @@ Summary:
124 (defgeneric ,method ,args) 124 (defgeneric ,method ,args)
125 (eieio--defmethod ',method ',key ',class #',code)))) 125 (eieio--defmethod ',method ',key ',class #',code))))
126 126
127(defun eieio--generic-static-symbol-specializers (tag)
128 (cl-assert (or (null tag) (eieio--class-p tag)))
129 (when (eieio--class-p tag)
130 (let ((superclasses (eieio--generic-subclass-specializers tag))
131 (specializers ()))
132 (dolist (superclass superclasses)
133 (push superclass specializers)
134 (push `(eieio--static ,(cadr superclass)) specializers))
135 (nreverse specializers))))
136
127(defconst eieio--generic-static-symbol-generalizer 137(defconst eieio--generic-static-symbol-generalizer
128 (cl-generic-make-generalizer 138 (cl-generic-make-generalizer
129 ;; Give it a slightly higher priority than `subclass' so that the 139 ;; Give it a slightly higher priority than `subclass' so that the
130 ;; interleaved list comes before subclass's non-interleaved list. 140 ;; interleaved list comes before subclass's non-interleaved list.
131 61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name))) 141 61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name)))
132 (lambda (tag) 142 #'eieio--generic-static-symbol-specializers))
133 (when (eieio--class-p tag)
134 (let ((superclasses (eieio--generic-subclass-specializers tag))
135 (specializers ()))
136 (dolist (superclass superclasses)
137 (push superclass specializers)
138 (push `(eieio--static ,(cadr superclass)) specializers))
139 (nreverse specializers))))))
140(defconst eieio--generic-static-object-generalizer 143(defconst eieio--generic-static-object-generalizer
141 (cl-generic-make-generalizer 144 (cl-generic-make-generalizer
142 ;; Give it a slightly higher priority than `class' so that the 145 ;; Give it a slightly higher priority than `class' so that the
@@ -148,7 +151,7 @@ Summary:
148 (let ((superclasses (eieio--class-precedence-list tag)) 151 (let ((superclasses (eieio--class-precedence-list tag))
149 (specializers ())) 152 (specializers ()))
150 (dolist (superclass superclasses) 153 (dolist (superclass superclasses)
151 (setq superclass (eieio--class-symbol superclass)) 154 (setq superclass (eieio--class-name superclass))
152 (push superclass specializers) 155 (push superclass specializers)
153 (push `(eieio--static ,superclass) specializers)) 156 (push `(eieio--static ,superclass) specializers))
154 (nreverse specializers)))))) 157 (nreverse specializers))))))
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 1e226c154e2..6fd9c14088e 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -85,9 +85,10 @@ Currently under control of this var:
85 ;; Arrange for field access not to bother checking if the access is indeed 85 ;; Arrange for field access not to bother checking if the access is indeed
86 ;; made to an eieio--class object. 86 ;; made to an eieio--class object.
87 (cl-declaim (optimize (safety 0))) 87 (cl-declaim (optimize (safety 0)))
88
88(cl-defstruct (eieio--class 89(cl-defstruct (eieio--class
89 (:constructor nil) 90 (:constructor nil)
90 (:constructor eieio--class-make (symbol &aux (tag 'defclass))) 91 (:constructor eieio--class-make (name &aux (tag 'defclass)))
91 (:type vector) 92 (:type vector)
92 (:copier nil)) 93 (:copier nil))
93 ;; We use an untagged cl-struct, with our own hand-made tag as first field 94 ;; 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:
96 ;; predicate for us), but that breaks compatibility with .elc files compiled 97 ;; predicate for us), but that breaks compatibility with .elc files compiled
97 ;; against older versions of EIEIO. 98 ;; against older versions of EIEIO.
98 tag 99 tag
99 symbol ;; symbol (self-referencing) 100 ;; Fields we could inherit from cl--class (if we used a tagged cl-struct):
100 parent children 101 (name nil :type symbol) ;The type name.
101 symbol-hashtable ;; hashtable permitting fast access to variable position indexes 102 (docstring nil :type string)
102 ;; @todo 103 (parents nil :type (or eieio--class (list-of eieio--class)))
103 ;; the word "public" here is leftovers from the very first version. 104 (slots nil :type (vector cl-slot-descriptor))
104 ;; Get rid of it! 105 (index-table nil :type hash-table)
105 public-a ;; class attribute index 106 ;; Fields specific to EIEIO classes:
106 public-d ;; class attribute defaults index 107 children
107 public-doc ;; class documentation strings for attributes
108 public-type ;; class type for a slot
109 public-custom ;; class custom type for a slot
110 public-custom-label ;; class custom group for a slot
111 public-custom-group ;; class custom group for a slot
112 public-printer ;; printer for a slot
113 protection ;; protection for a slot
114 initarg-tuples ;; initarg tuples list 108 initarg-tuples ;; initarg tuples list
115 class-allocation-a ;; class allocated attributes 109 (class-slots nil :type eieio--slot)
116 class-allocation-doc ;; class allocated documentation
117 class-allocation-type ;; class allocated value type
118 class-allocation-custom ;; class allocated custom descriptor
119 class-allocation-custom-label ;; class allocated custom descriptor
120 class-allocation-custom-group ;; class allocated custom group
121 class-allocation-printer ;; class allocated printer for a slot
122 class-allocation-protection ;; class allocated protection list
123 class-allocation-values ;; class allocated value vector 110 class-allocation-values ;; class allocated value vector
124 default-object-cache ;; what a newly created object would look like. 111 default-object-cache ;; what a newly created object would look like.
125 ; This will speed up instantiation time as 112 ; This will speed up instantiation time as
@@ -142,18 +129,13 @@ Currently under control of this var:
142 ;; object/struct in its `symbol-value' slot. 129 ;; object/struct in its `symbol-value' slot.
143 class-tag) 130 class-tag)
144 131
145(eval-and-compile 132(eval-when-compile
146 (defconst eieio--object-num-slots 133 (defconst eieio--object-num-slots
147 (length (get 'eieio--object 'cl-struct-slots)))) 134 (length (cl-struct-slot-info 'eieio--object))))
148 135
149(defsubst eieio--object-class-object (obj) 136(defsubst eieio--object-class (obj)
150 (symbol-value (eieio--object-class-tag obj))) 137 (symbol-value (eieio--object-class-tag obj)))
151 138
152(defsubst eieio--object-class-name (obj)
153 ;; FIXME: Most uses of this function should be changed to use
154 ;; eieio--object-class-object instead!
155 (eieio--class-symbol (eieio--object-class-object obj)))
156
157 139
158;;; Important macros used internally in eieio. 140;;; Important macros used internally in eieio.
159 141
@@ -189,7 +171,7 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
189 "Return a Lisp like symbol name for CLASS." 171 "Return a Lisp like symbol name for CLASS."
190 (setq class (eieio--class-object class)) 172 (setq class (eieio--class-object class))
191 (cl-check-type class eieio--class) 173 (cl-check-type class eieio--class)
192 (eieio--class-symbol class)) 174 (eieio--class-name class))
193(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") 175(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
194 176
195(defalias 'eieio--class-constructor #'identity 177(defalias 'eieio--class-constructor #'identity
@@ -354,10 +336,10 @@ See `defclass' for more information."
354 (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) 336 (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
355 (eieio--class-option c :custom-groups)) 337 (eieio--class-option c :custom-groups))
356 ;; Save parent in child. 338 ;; Save parent in child.
357 (push c (eieio--class-parent newc)))))) 339 (push c (eieio--class-parents newc))))))
358 ;; Reverse the list of our parents so that they are prioritized in 340 ;; Reverse the list of our parents so that they are prioritized in
359 ;; the same order as specified in the code. 341 ;; the same order as specified in the code.
360 (cl-callf nreverse (eieio--class-parent newc))) 342 (cl-callf nreverse (eieio--class-parents newc)))
361 ;; If there is nothing to loop over, then inherit from the 343 ;; If there is nothing to loop over, then inherit from the
362 ;; default superclass. 344 ;; default superclass.
363 (unless (eq cname 'eieio-default-superclass) 345 (unless (eq cname 'eieio-default-superclass)
@@ -366,7 +348,7 @@ See `defclass' for more information."
366 ;; save new child in parent 348 ;; save new child in parent
367 (cl-pushnew cname (eieio--class-children eieio-default-superclass)) 349 (cl-pushnew cname (eieio--class-children eieio-default-superclass))
368 ;; save parent in child 350 ;; save parent in child
369 (setf (eieio--class-parent newc) (list eieio-default-superclass)))) 351 (setf (eieio--class-parents newc) (list eieio-default-superclass))))
370 352
371 ;; turn this into a usable self-pointing symbol; FIXME: Why? 353 ;; turn this into a usable self-pointing symbol; FIXME: Why?
372 (when eieio-backward-compatibility 354 (when eieio-backward-compatibility
@@ -442,62 +424,70 @@ See `defclass' for more information."
442 (make-obsolete-variable 424 (make-obsolete-variable
443 initarg (format "use '%s instead" initarg) "25.1")))) 425 initarg (format "use '%s instead" initarg) "25.1"))))
444 426
445 ;; The customgroup should be a list of symbols 427 ;; The customgroup should be a list of symbols.
446 (cond ((null customg) 428 (cond ((and (null customg) custom)
447 (setq customg '(default))) 429 (setq customg '(default)))
448 ((not (listp customg)) 430 ((not (listp customg))
449 (setq customg (list customg)))) 431 (setq customg (list customg))))
450 ;; The customgroup better be a symbol, or list of symbols. 432 ;; The customgroup better be a list of symbols.
451 (mapc (lambda (cg) 433 (dolist (cg customg)
452 (if (not (symbolp cg)) 434 (unless (symbolp cg)
453 (signal 'invalid-slot-type (list :group cg)))) 435 (signal 'invalid-slot-type (list :group cg))))
454 customg)
455 436
456 ;; First up, add this slot into our new class. 437 ;; First up, add this slot into our new class.
457 (eieio--add-new-slot newc name init docstr type custom label customg printer 438 (eieio--add-new-slot
458 prot initarg alloc 'defaultoverride skip-nil) 439 newc (cl--make-slot-descriptor
440 name init type
441 `(,@(if docstr `((:documentation . ,docstr)))
442 ,@(if custom `((:custom . ,custom)))
443 ,@(if label `((:label . ,label)))
444 ,@(if customg `((:group . ,customg)))
445 ,@(if printer `((:printer . ,printer)))
446 ,@(if prot `((:protection . ,prot)))))
447 initarg alloc 'defaultoverride skip-nil)
459 448
460 ;; We need to id the group, and store them in a group list attribute. 449 ;; We need to id the group, and store them in a group list attribute.
461 (dolist (cg customg) 450 (dolist (cg customg)
462 (cl-pushnew cg groups :test 'equal)) 451 (cl-pushnew cg groups :test #'equal))
463 )) 452 ))
464 453
465 ;; Now that everything has been loaded up, all our lists are backwards! 454 ;; Now that everything has been loaded up, all our lists are backwards!
466 ;; Fix that up now. 455 ;; Fix that up now and then them into vectors.
467 (cl-callf nreverse (eieio--class-public-a newc)) 456 (cl-callf (lambda (slots) (apply #'vector (nreverse slots)))
468 (cl-callf nreverse (eieio--class-public-d newc)) 457 (eieio--class-slots newc))
469 (cl-callf nreverse (eieio--class-public-doc newc))
470 (cl-callf (lambda (types) (apply #'vector (nreverse types)))
471 (eieio--class-public-type newc))
472 (cl-callf nreverse (eieio--class-public-custom newc))
473 (cl-callf nreverse (eieio--class-public-custom-label newc))
474 (cl-callf nreverse (eieio--class-public-custom-group newc))
475 (cl-callf nreverse (eieio--class-public-printer newc))
476 (cl-callf nreverse (eieio--class-protection newc))
477 (cl-callf nreverse (eieio--class-initarg-tuples newc)) 458 (cl-callf nreverse (eieio--class-initarg-tuples newc))
478 459
479 ;; The storage for class-class-allocation-type needs to be turned into 460 ;; The storage for class-class-allocation-type needs to be turned into
480 ;; a vector now. 461 ;; a vector now.
481 (cl-callf (lambda (cat) (apply #'vector cat)) 462 (cl-callf (lambda (slots) (apply #'vector slots))
482 (eieio--class-class-allocation-type newc)) 463 (eieio--class-class-slots newc))
483 464
484 ;; Also, take class allocated values, and vectorize them for speed. 465 ;; Also, setup the class allocated values.
485 (cl-callf (lambda (cavs) (apply #'vector cavs)) 466 (let* ((slots (eieio--class-class-slots newc))
486 (eieio--class-class-allocation-values newc)) 467 (n (length slots))
468 (v (make-vector n nil)))
469 (dotimes (i n)
470 (setf (aref v i) (eieio-default-eval-maybe
471 (cl--slot-descriptor-initform (aref slots i)))))
472 (setf (eieio--class-class-allocation-values newc) v))
487 473
488 ;; Attach slot symbols into a hashtable, and store the index of 474 ;; Attach slot symbols into a hashtable, and store the index of
489 ;; this slot as the value this table. 475 ;; this slot as the value this table.
490 (let* ((cnt 0) 476 (let* ((slots (eieio--class-slots newc))
477 ;; (cslots (eieio--class-class-slots newc))
491 (oa (make-hash-table :test #'eq))) 478 (oa (make-hash-table :test #'eq)))
492 (dolist (pubsym (eieio--class-public-a newc)) 479 ;; (dotimes (cnt (length cslots))
493 (setf (gethash pubsym oa) cnt) 480 ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt)))
494 (setq cnt (1+ cnt))) 481 (dotimes (cnt (length slots))
495 (setf (eieio--class-symbol-hashtable newc) oa)) 482 (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt))
483 (setf (eieio--class-index-table newc) oa))
496 484
497 ;; Set up a specialized doc string. 485 ;; Set up a specialized doc string.
498 ;; Use stored value since it is calculated in a non-trivial way 486 ;; Use stored value since it is calculated in a non-trivial way
499 (put cname 'variable-documentation 487 (let ((docstring (eieio--class-option-assoc options :documentation)))
500 (eieio--class-option-assoc options :documentation)) 488 (setf (eieio--class-docstring newc) docstring)
489 (when eieio-backward-compatibility
490 (put cname 'variable-documentation docstring)))
501 491
502 ;; Save the file location where this class is defined. 492 ;; Save the file location where this class is defined.
503 (add-to-list 'current-load-list `(eieio-defclass . ,cname)) 493 (add-to-list 'current-load-list `(eieio-defclass . ,cname))
@@ -514,10 +504,10 @@ See `defclass' for more information."
514 504
515 ;; if this is a superclass, clear out parent (which was set to the 505 ;; if this is a superclass, clear out parent (which was set to the
516 ;; default superclass eieio-default-superclass) 506 ;; default superclass eieio-default-superclass)
517 (if clearparent (setf (eieio--class-parent newc) nil)) 507 (if clearparent (setf (eieio--class-parents newc) nil))
518 508
519 ;; Create the cached default object. 509 ;; Create the cached default object.
520 (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 510 (let ((cache (make-vector (+ (length (eieio--class-slots newc))
521 (eval-when-compile eieio--object-num-slots)) 511 (eval-when-compile eieio--object-num-slots))
522 nil)) 512 nil))
523 ;; We don't strictly speaking need to use a symbol, but the old 513 ;; We don't strictly speaking need to use a symbol, but the old
@@ -544,239 +534,133 @@ See `defclass' for more information."
544 "Whether the default value VAL should be evaluated for use." 534 "Whether the default value VAL should be evaluated for use."
545 (and (consp val) (symbolp (car val)) (fboundp (car val)))) 535 (and (consp val) (symbolp (car val)) (fboundp (car val))))
546 536
547(defun eieio--perform-slot-validation-for-default (slot spec value skipnil) 537(defun eieio--perform-slot-validation-for-default (slot skipnil)
548 "For SLOT, signal if SPEC does not match VALUE. 538 "For SLOT, signal if its type does not match its default value.
549If SKIPNIL is non-nil, then if VALUE is nil return t instead." 539If SKIPNIL is non-nil, then if default value is nil return t instead."
550 (if (not (or (eieio-eval-default-p value) ;FIXME: Why? 540 (let ((value (cl--slot-descriptor-initform slot))
551 eieio-skip-typecheck 541 (spec (cl--slot-descriptor-type slot)))
552 (and skipnil (null value)) 542 (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
553 (eieio--perform-slot-validation spec value))) 543 eieio-skip-typecheck
554 (signal 'invalid-slot-type (list slot spec value)))) 544 (and skipnil (null value))
555 545 (eieio--perform-slot-validation spec value)))
556(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc 546 (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value)))))
547
548(defun eieio--slot-override (old new skipnil)
549 (cl-assert (eq (cl--slot-descriptor-name old) (cl--slot-descriptor-name new)))
550 ;; There is a match, and we must override the old value.
551 (let* ((a (cl--slot-descriptor-name old))
552 (tp (cl--slot-descriptor-type old))
553 (d (cl--slot-descriptor-initform new))
554 (type (cl--slot-descriptor-type new))
555 (oprops (cl--slot-descriptor-props old))
556 (nprops (cl--slot-descriptor-props new))
557 (custg (alist-get :group nprops)))
558 ;; If type is passed in, is it the same?
559 (if (not (eq type t))
560 (if (not (equal type tp))
561 (error
562 "Child slot type `%s' does not match inherited type `%s' for `%s'"
563 type tp a))
564 (setf (cl--slot-descriptor-type new) tp))
565 ;; If we have a repeat, only update the initarg...
566 (unless (eq d eieio-unbound)
567 (eieio--perform-slot-validation-for-default new skipnil)
568 (setf (cl--slot-descriptor-initform old) d))
569
570 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
571 ;; checked and SHOULD match the superclass
572 ;; protection. Otherwise an error is thrown. However
573 ;; I wonder if a more flexible schedule might be
574 ;; implemented.
575 ;;
576 ;; EML - We used to have (if prot... here,
577 ;; but a prot of 'nil means public.
578 ;;
579 (let ((super-prot (alist-get :protection oprops))
580 (prot (alist-get :protection nprops)))
581 (if (not (eq prot super-prot))
582 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
583 prot super-prot a)))
584 ;; End original PLN
585
586 ;; PLN Tue Jun 26 11:57:06 2007 :
587 ;; Do a non redundant combination of ancient custom
588 ;; groups and new ones.
589 (when custg
590 (let* ((list1 (alist-get :group oprops)))
591 (dolist (elt custg)
592 (unless (memq elt list1)
593 (push elt list1)))
594 (setf (alist-get :group (cl--slot-descriptor-props old)) list1)))
595 ;; End PLN
596
597 ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is
598 ;; set, simply replaces the old one.
599 (dolist (prop '(:custom :label :documentation :printer))
600 (when (alist-get prop (cl--slot-descriptor-props new))
601 (setf (alist-get prop (cl--slot-descriptor-props old))
602 (alist-get prop (cl--slot-descriptor-props new))))
603
604 ) ))
605
606(defun eieio--add-new-slot (newc slot init alloc
557 &optional defaultoverride skipnil) 607 &optional defaultoverride skipnil)
558 "Add into NEWC attribute A. 608 "Add into NEWC attribute SLOT.
559If A already exists in NEWC, then do nothing. If it doesn't exist, 609If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist,
560then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. 610INIT is the initarg, if any.
561Argument ALLOC specifies if the slot is allocated per instance, or per class. 611Argument ALLOC specifies if the slot is allocated per instance, or per class.
562If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, 612If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC,
563we must override its value for a default. 613we must override its value for a default.
564Optional argument SKIPNIL indicates if type checking should be skipped 614Optional argument SKIPNIL indicates if type checking should be skipped
565if default value is nil." 615if default value is nil."
566 ;; Make sure we duplicate those items that are sequences. 616 ;; Make sure we duplicate those items that are sequences.
617 (let* ((a (cl--slot-descriptor-name slot))
618 (d (cl--slot-descriptor-initform slot))
619 (old (car (cl-member a (eieio--class-slots newc)
620 :key #'cl--slot-descriptor-name)))
621 (cold (car (cl-member a (eieio--class-class-slots newc)
622 :key #'cl--slot-descriptor-name))))
567 (condition-case nil 623 (condition-case nil
568 (if (sequencep d) (setq d (copy-sequence d))) 624 (if (sequencep d) (setq d (copy-sequence d)))
569 ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. 625 ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's
626 ;; skip it if it doesn't work.
570 (error nil)) 627 (error nil))
571 (if (sequencep type) (setq type (copy-sequence type))) 628 ;; (if (sequencep type) (setq type (copy-sequence type)))
572 (if (sequencep cust) (setq cust (copy-sequence cust))) 629 ;; (if (sequencep cust) (setq cust (copy-sequence cust)))
573 (if (sequencep custg) (setq custg (copy-sequence custg))) 630 ;; (if (sequencep custg) (setq custg (copy-sequence custg)))
574 631
575 ;; To prevent override information w/out specification of storage, 632 ;; To prevent override information w/out specification of storage,
576 ;; we need to do this little hack. 633 ;; we need to do this little hack.
577 (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class)) 634 (if cold (setq alloc :class))
578 635
579 (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance))) 636 (if (memq alloc '(nil :instance))
580 ;; In this case, we modify the INSTANCE version of a given slot. 637 ;; In this case, we modify the INSTANCE version of a given slot.
581
582 (progn 638 (progn
583 639 ;; Only add this element if it is so-far unique
584 ;; Only add this element if it is so-far unique 640 (if (not old)
585 (if (not (member a (eieio--class-public-a newc))) 641 (progn
586 (progn 642 (eieio--perform-slot-validation-for-default slot skipnil)
587 (eieio--perform-slot-validation-for-default a type d skipnil) 643 (push slot (eieio--class-slots newc))
588 (push a (eieio--class-public-a newc)) 644 )
589 (push d (eieio--class-public-d newc)) 645 ;; When defaultoverride is true, we are usually adding new local
590 (push doc (eieio--class-public-doc newc)) 646 ;; attributes which must override the default value of any slot
591 (push type (eieio--class-public-type newc)) 647 ;; passed in by one of the parent classes.
592 (push cust (eieio--class-public-custom newc)) 648 (when defaultoverride
593 (push label (eieio--class-public-custom-label newc)) 649 (eieio--slot-override old slot skipnil)))
594 (push custg (eieio--class-public-custom-group newc)) 650 (when init
595 (push print (eieio--class-public-printer newc)) 651 (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc)
596 (push prot (eieio--class-protection newc)) 652 :test #'equal)))
597 (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc)))
598 )
599 ;; When defaultoverride is true, we are usually adding new local
600 ;; attributes which must override the default value of any slot
601 ;; passed in by one of the parent classes.
602 (when defaultoverride
603 ;; There is a match, and we must override the old value.
604 (let* ((ca (eieio--class-public-a newc))
605 (np (member a ca))
606 (num (- (length ca) (length np)))
607 (dp (if np (nthcdr num (eieio--class-public-d newc))
608 nil))
609 (tp (if np (nth num (eieio--class-public-type newc))))
610 )
611 (if (not np)
612 (error "EIEIO internal error overriding default value for %s"
613 a)
614 ;; If type is passed in, is it the same?
615 (if (not (eq type t))
616 (if (not (equal type tp))
617 (error
618 "Child slot type `%s' does not match inherited type `%s' for `%s'"
619 type tp a)))
620 ;; If we have a repeat, only update the initarg...
621 (unless (eq d eieio-unbound)
622 (eieio--perform-slot-validation-for-default a tp d skipnil)
623 (setcar dp d))
624 ;; If we have a new initarg, check for it.
625 (when init
626 (let* ((inits (eieio--class-initarg-tuples newc))
627 (inita (rassq a inits)))
628 ;; Replace the CAR of the associate INITA.
629 ;;(message "Initarg: %S replace %s" inita init)
630 (setcar inita init)
631 ))
632
633 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
634 ;; checked and SHOULD match the superclass
635 ;; protection. Otherwise an error is thrown. However
636 ;; I wonder if a more flexible schedule might be
637 ;; implemented.
638 ;;
639 ;; EML - We used to have (if prot... here,
640 ;; but a prot of 'nil means public.
641 ;;
642 (let ((super-prot (nth num (eieio--class-protection newc)))
643 )
644 (if (not (eq prot super-prot))
645 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
646 prot super-prot a)))
647 ;; End original PLN
648
649 ;; PLN Tue Jun 26 11:57:06 2007 :
650 ;; Do a non redundant combination of ancient custom
651 ;; groups and new ones.
652 (when custg
653 (let* ((groups
654 (nthcdr num (eieio--class-public-custom-group newc)))
655 (list1 (car groups))
656 (list2 (if (listp custg) custg (list custg))))
657 (if (< (length list1) (length list2))
658 (setq list1 (prog1 list2 (setq list2 list1))))
659 (dolist (elt list2)
660 (unless (memq elt list1)
661 (push elt list1)))
662 (setcar groups list1)))
663 ;; End PLN
664
665 ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is
666 ;; set, simply replaces the old one.
667 (when cust
668 ;; (message "Custom type redefined to %s" cust)
669 (setcar (nthcdr num (eieio--class-public-custom newc)) cust))
670
671 ;; If a new label is specified, it simply replaces
672 ;; the old one.
673 (when label
674 ;; (message "Custom label redefined to %s" label)
675 (setcar (nthcdr num (eieio--class-public-custom-label newc)) label))
676 ;; End PLN
677
678 ;; PLN Sat Jun 30 17:24:42 2007 : when a new
679 ;; doc is specified, simply replaces the old one.
680 (when doc
681 ;;(message "Documentation redefined to %s" doc)
682 (setcar (nthcdr num (eieio--class-public-doc newc))
683 doc))
684 ;; End PLN
685
686 ;; If a new printer is specified, it simply replaces
687 ;; the old one.
688 (when print
689 ;; (message "printer redefined to %s" print)
690 (setcar (nthcdr num (eieio--class-public-printer newc)) print))
691
692 )))
693 ))
694 653
695 ;; CLASS ALLOCATED SLOTS 654 ;; CLASS ALLOCATED SLOTS
696 (let ((value (eieio-default-eval-maybe d))) 655 (if (not cold)
697 (if (not (member a (eieio--class-class-allocation-a newc))) 656 (progn
698 (progn 657 (eieio--perform-slot-validation-for-default slot skipnil)
699 (eieio--perform-slot-validation-for-default a type value skipnil) 658 ;; Here we have found a :class version of a slot. This
700 ;; Here we have found a :class version of a slot. This 659 ;; requires a very different approach.
701 ;; requires a very different approach. 660 (push slot (eieio--class-class-slots newc)))
702 (push a (eieio--class-class-allocation-a newc)) 661 (when defaultoverride
703 (push doc (eieio--class-class-allocation-doc newc)) 662 ;; There is a match, and we must override the old value.
704 (push type (eieio--class-class-allocation-type newc)) 663 (eieio--slot-override cold slot skipnil))))))
705 (push cust (eieio--class-class-allocation-custom newc))
706 (push label (eieio--class-class-allocation-custom-label newc))
707 (push custg (eieio--class-class-allocation-custom-group newc))
708 (push prot (eieio--class-class-allocation-protection newc))
709 ;; Default value is stored in the 'values section, since new objects
710 ;; can't initialize from this element.
711 (push value (eieio--class-class-allocation-values newc)))
712 (when defaultoverride
713 ;; There is a match, and we must override the old value.
714 (let* ((ca (eieio--class-class-allocation-a newc))
715 (np (member a ca))
716 (num (- (length ca) (length np)))
717 (dp (if np
718 (nthcdr num
719 (eieio--class-class-allocation-values newc))
720 nil))
721 (tp (if np (nth num (eieio--class-class-allocation-type newc))
722 nil)))
723 (if (not np)
724 (error "EIEIO internal error overriding default value for %s"
725 a)
726 ;; If type is passed in, is it the same?
727 (if (not (eq type t))
728 (if (not (equal type tp))
729 (error
730 "Child slot type `%s' does not match inherited type `%s' for `%s'"
731 type tp a)))
732 ;; EML - Note: the only reason to override a class bound slot
733 ;; is to change the default, so allow unbound in.
734
735 ;; If we have a repeat, only update the value...
736 (eieio--perform-slot-validation-for-default a tp value skipnil)
737 (setcar dp value))
738
739 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
740 ;; checked and SHOULD match the superclass
741 ;; protection. Otherwise an error is thrown. However
742 ;; I wonder if a more flexible schedule might be
743 ;; implemented.
744 (let ((super-prot
745 (car (nthcdr num (eieio--class-class-allocation-protection newc)))))
746 (if (not (eq prot super-prot))
747 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
748 prot super-prot a)))
749 ;; Do a non redundant combination of ancient custom groups
750 ;; and new ones.
751 (when custg
752 (let* ((groups
753 (nthcdr num (eieio--class-class-allocation-custom-group newc)))
754 (list1 (car groups))
755 (list2 (if (listp custg) custg (list custg))))
756 (if (< (length list1) (length list2))
757 (setq list1 (prog1 list2 (setq list2 list1))))
758 (dolist (elt list2)
759 (unless (memq elt list1)
760 (push elt list1)))
761 (setcar groups list1)))
762
763 ;; PLN Sat Jun 30 17:24:42 2007 : when a new
764 ;; doc is specified, simply replaces the old one.
765 (when doc
766 ;;(message "Documentation redefined to %s" doc)
767 (setcar (nthcdr num (eieio--class-class-allocation-doc newc))
768 doc))
769 ;; End PLN
770
771 ;; If a new printer is specified, it simply replaces
772 ;; the old one.
773 (when print
774 ;; (message "printer redefined to %s" print)
775 (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print))
776
777 ))
778 ))
779 ))
780 664
781(defun eieio-copy-parents-into-subclass (newc) 665(defun eieio-copy-parents-into-subclass (newc)
782 "Copy into NEWC the slots of PARENTS. 666 "Copy into NEWC the slots of PARENTS.
@@ -784,63 +668,22 @@ Follow the rules of not overwriting early parents when applying to
784the new child class." 668the new child class."
785 (let ((sn (eieio--class-option-assoc (eieio--class-options newc) 669 (let ((sn (eieio--class-option-assoc (eieio--class-options newc)
786 :allow-nil-initform))) 670 :allow-nil-initform)))
787 (dolist (pcv (eieio--class-parent newc)) 671 (dolist (pcv (eieio--class-parents newc))
788 ;; First, duplicate all the slots of the parent. 672 ;; First, duplicate all the slots of the parent.
789 (let ((pa (eieio--class-public-a pcv)) 673 (let ((pslots (eieio--class-slots pcv))
790 (pd (eieio--class-public-d pcv)) 674 (pinit (eieio--class-initarg-tuples pcv)))
791 (pdoc (eieio--class-public-doc pcv)) 675 (dotimes (i (length pslots))
792 (ptype (eieio--class-public-type pcv)) 676 (eieio--add-new-slot newc (cl--copy-slot-descriptor (aref pslots i))
793 (pcust (eieio--class-public-custom pcv)) 677 (car-safe (car pinit)) nil nil sn)
794 (plabel (eieio--class-public-custom-label pcv))
795 (pcustg (eieio--class-public-custom-group pcv))
796 (printer (eieio--class-public-printer pcv))
797 (pprot (eieio--class-protection pcv))
798 (pinit (eieio--class-initarg-tuples pcv))
799 (i 0))
800 (while pa
801 (eieio--add-new-slot newc
802 (car pa) (car pd) (car pdoc) (aref ptype i)
803 (car pcust) (car plabel) (car pcustg)
804 (car printer)
805 (car pprot) (car-safe (car pinit)) nil nil sn)
806 ;; Increment each value. 678 ;; Increment each value.
807 (setq pa (cdr pa) 679 (setq pinit (cdr pinit))
808 pd (cdr pd)
809 pdoc (cdr pdoc)
810 i (1+ i)
811 pcust (cdr pcust)
812 plabel (cdr plabel)
813 pcustg (cdr pcustg)
814 printer (cdr printer)
815 pprot (cdr pprot)
816 pinit (cdr pinit))
817 )) ;; while/let 680 )) ;; while/let
818 ;; Now duplicate all the class alloc slots. 681 ;; Now duplicate all the class alloc slots.
819 (let ((pa (eieio--class-class-allocation-a pcv)) 682 (let ((pcslots (eieio--class-class-slots pcv)))
820 (pdoc (eieio--class-class-allocation-doc pcv)) 683 (dotimes (i (length pcslots))
821 (ptype (eieio--class-class-allocation-type pcv)) 684 (eieio--add-new-slot newc (cl--copy-slot-descriptor
822 (pcust (eieio--class-class-allocation-custom pcv)) 685 (aref pcslots i))
823 (plabel (eieio--class-class-allocation-custom-label pcv)) 686 nil :class sn)
824 (pcustg (eieio--class-class-allocation-custom-group pcv))
825 (printer (eieio--class-class-allocation-printer pcv))
826 (pprot (eieio--class-class-allocation-protection pcv))
827 (pval (eieio--class-class-allocation-values pcv))
828 (i 0))
829 (while pa
830 (eieio--add-new-slot newc
831 (car pa) (aref pval i) (car pdoc) (aref ptype i)
832 (car pcust) (car plabel) (car pcustg)
833 (car printer)
834 (car pprot) nil :class sn)
835 ;; Increment each value.
836 (setq pa (cdr pa)
837 pdoc (cdr pdoc)
838 pcust (cdr pcust)
839 plabel (cdr plabel)
840 pcustg (cdr pcustg)
841 printer (cdr printer)
842 pprot (cdr pprot)
843 i (1+ i))
844 ))))) 687 )))))
845 688
846 689
@@ -865,10 +708,11 @@ an error."
865 nil 708 nil
866 ;; Trim off object IDX junk added in for the object index. 709 ;; Trim off object IDX junk added in for the object index.
867 (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) 710 (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
868 (let ((st (aref (eieio--class-public-type class) slot-idx))) 711 (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class)
712 slot-idx))))
869 (if (not (eieio--perform-slot-validation st value)) 713 (if (not (eieio--perform-slot-validation st value))
870 (signal 'invalid-slot-type 714 (signal 'invalid-slot-type
871 (list (eieio--class-symbol class) slot st value)))))) 715 (list (eieio--class-name class) slot st value))))))
872 716
873(defun eieio--validate-class-slot-value (class slot-idx value slot) 717(defun eieio--validate-class-slot-value (class slot-idx value slot)
874 "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. 718 "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
877an error." 721an error."
878 (if eieio-skip-typecheck 722 (if eieio-skip-typecheck
879 nil 723 nil
880 (let ((st (aref (eieio--class-class-allocation-type class) 724 (let ((st (cl--slot-descriptor-type (aref (eieio--class-class-slots class)
881 slot-idx))) 725 slot-idx))))
882 (if (not (eieio--perform-slot-validation st value)) 726 (if (not (eieio--perform-slot-validation st value))
883 (signal 'invalid-slot-type 727 (signal 'invalid-slot-type
884 (list (eieio--class-symbol class) slot st value)))))) 728 (list (eieio--class-name class) slot st value))))))
885 729
886(defun eieio-barf-if-slot-unbound (value instance slotname fn) 730(defun eieio-barf-if-slot-unbound (value instance slotname fn)
887 "Throw a signal if VALUE is a representation of an UNBOUND slot. 731 "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
889slot. If the slot is ok, return VALUE. 733slot. If the slot is ok, return VALUE.
890Argument FN is the function calling this verifier." 734Argument FN is the function calling this verifier."
891 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) 735 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
892 (slot-unbound instance (eieio--object-class-object instance) slotname fn) 736 (slot-unbound instance (eieio--object-class instance) slotname fn)
893 value)) 737 value))
894 738
895 739
@@ -904,7 +748,7 @@ Argument FN is the function calling this verifier."
904 (let ((c (eieio--class-v obj))) 748 (let ((c (eieio--class-v obj)))
905 (if (eieio--class-p c) (eieio-class-un-autoload obj)) 749 (if (eieio--class-p c) (eieio-class-un-autoload obj))
906 c)) 750 c))
907 (t (eieio--object-class-object obj)))) 751 (t (eieio--object-class obj))))
908 (c (eieio--slot-name-index class slot))) 752 (c (eieio--slot-name-index class slot)))
909 (if (not c) 753 (if (not c)
910 ;; It might be missing because it is a :class allocated slot. 754 ;; It might be missing because it is a :class allocated slot.
@@ -928,7 +772,7 @@ Fills in OBJ's SLOT with its default value."
928 (cl-check-type obj (or eieio-object class)) 772 (cl-check-type obj (or eieio-object class))
929 (cl-check-type slot symbol) 773 (cl-check-type slot symbol)
930 (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) 774 (let* ((cl (cond ((symbolp obj) (eieio--class-v obj))
931 (t (eieio--object-class-object obj)))) 775 (t (eieio--object-class obj))))
932 (c (eieio--slot-name-index cl slot))) 776 (c (eieio--slot-name-index cl slot)))
933 (if (not c) 777 (if (not c)
934 ;; It might be missing because it is a :class allocated slot. 778 ;; It might be missing because it is a :class allocated slot.
@@ -942,10 +786,11 @@ Fills in OBJ's SLOT with its default value."
942 ;;(signal 'invalid-slot-name (list (class-name cl) slot)) 786 ;;(signal 'invalid-slot-name (list (class-name cl) slot))
943 ) 787 )
944 (eieio-barf-if-slot-unbound 788 (eieio-barf-if-slot-unbound
945 (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) 789 (let ((val (cl--slot-descriptor-initform
946 (eieio--class-public-d cl)))) 790 (aref (eieio--class-slots cl)
791 (- c (eval-when-compile eieio--object-num-slots))))))
947 (eieio-default-eval-maybe val)) 792 (eieio-default-eval-maybe val))
948 obj (eieio--class-symbol cl) 'oref-default)))) 793 obj (eieio--class-name cl) 'oref-default))))
949 794
950(defun eieio-default-eval-maybe (val) 795(defun eieio-default-eval-maybe (val)
951 "Check VAL, and return what `oref-default' would provide." 796 "Check VAL, and return what `oref-default' would provide."
@@ -966,7 +811,7 @@ Fills in OBJ's SLOT with its default value."
966Fills in OBJ's SLOT with VALUE." 811Fills in OBJ's SLOT with VALUE."
967 (cl-check-type obj eieio-object) 812 (cl-check-type obj eieio-object)
968 (cl-check-type slot symbol) 813 (cl-check-type slot symbol)
969 (let* ((class (eieio--object-class-object obj)) 814 (let* ((class (eieio--object-class obj))
970 (c (eieio--slot-name-index class slot))) 815 (c (eieio--slot-name-index class slot)))
971 (if (not c) 816 (if (not c)
972 ;; It might be missing because it is a :class allocated slot. 817 ;; 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."
1001 (eieio--validate-class-slot-value class c value slot) 846 (eieio--validate-class-slot-value class c value slot)
1002 (aset (eieio--class-class-allocation-values class) c 847 (aset (eieio--class-class-allocation-values class) c
1003 value)) 848 value))
1004 (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) 849 (signal 'invalid-slot-name (list (eieio--class-name class) slot)))
850 ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
851 ;; not by CLOS and is mildly inconsistent with the :initform thingy, so
852 ;; it'd be nice to get of it. This said, it is/was used at one place by
853 ;; gnus/registry.el, so it might be used elsewhere as well, so let's
854 ;; keep it for now.
855 ;; FIXME: Generate a compile-time warning for it!
856 ;; (error "Can't `oset-default' an instance-allocated slot: %S of %S"
857 ;; slot class)
1005 (eieio--validate-slot-value class c value slot) 858 (eieio--validate-slot-value class c value slot)
1006 ;; Set this into the storage for defaults. 859 ;; Set this into the storage for defaults.
1007 (if (eieio-eval-default-p value) 860 (if (eieio-eval-default-p value)
1008 (error "Can't set default to a sexp that gets evaluated again")) 861 (error "Can't set default to a sexp that gets evaluated again"))
1009 (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) 862 (setf (cl--slot-descriptor-initform
1010 (eieio--class-public-d class)) 863 ;; FIXME: Apparently we set it both in `slots' and in
864 ;; `object-cache', which seems redundant.
865 (aref (eieio--class-slots class)
866 (- c (eval-when-compile eieio--object-num-slots))))
1011 value) 867 value)
1012 ;; Take the value, and put it into our cache object. 868 ;; Take the value, and put it into our cache object.
1013 (eieio-oset (eieio--class-default-object-cache class) 869 (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.
1023If SLOT is the value created with :initarg instead, 879If SLOT is the value created with :initarg instead,
1024reverse-lookup that name, and recurse with the associated slot value." 880reverse-lookup that name, and recurse with the associated slot value."
1025 ;; Removed checks to outside this call 881 ;; Removed checks to outside this call
1026 (let* ((fsi (gethash slot (eieio--class-symbol-hashtable class)))) 882 (let* ((fsi (gethash slot (eieio--class-index-table class))))
1027 (if (integerp fsi) 883 (if (integerp fsi)
1028 (+ (eval-when-compile eieio--object-num-slots) fsi) 884 (+ (eval-when-compile eieio--object-num-slots) fsi)
1029 (let ((fn (eieio--initarg-to-attribute class slot))) 885 (let ((fn (eieio--initarg-to-attribute class slot)))
1030 (if fn (eieio--slot-name-index class fn) nil))))) 886 (if fn
887 ;; Accessing a slot via its :initarg is accepted by EIEIO
888 ;; (but not CLOS) but is a bad idea (for one: it's slower).
889 ;; FIXME: We should emit a compile-time warning when this happens!
890 (eieio--slot-name-index class fn)
891 nil)))))
1031 892
1032(defun eieio--class-slot-name-index (class slot) 893(defun eieio--class-slot-name-index (class slot)
1033 "In CLASS find the index of the named SLOT. 894 "In CLASS find the index of the named SLOT.
@@ -1036,13 +897,12 @@ call. If SLOT is the value created with :initarg instead,
1036reverse-lookup that name, and recurse with the associated slot value." 897reverse-lookup that name, and recurse with the associated slot value."
1037 ;; This will happen less often, and with fewer slots. Do this the 898 ;; This will happen less often, and with fewer slots. Do this the
1038 ;; storage cheap way. 899 ;; storage cheap way.
1039 (let* ((a (eieio--class-class-allocation-a class)) 900 (let ((index nil)
1040 (l1 (length a)) 901 (slots (eieio--class-class-slots class)))
1041 (af (memq slot a)) 902 (dotimes (i (length slots))
1042 (l2 (length af))) 903 (if (eq slot (cl--slot-descriptor-name (aref slots i)))
1043 ;; Slot # is length of the total list, minus the remaining list of 904 (setq index i)))
1044 ;; the found slot. 905 index))
1045 (if af (- l1 l2))))
1046 906
1047;;; 907;;;
1048;; Way to assign slots based on a list. Used for constructors, or 908;; 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."
1053If SET-ALL is non-nil, then when a default is nil, that value is 913If SET-ALL is non-nil, then when a default is nil, that value is
1054reset. If SET-ALL is nil, the slots are only reset if the default is 914reset. If SET-ALL is nil, the slots are only reset if the default is
1055not nil." 915not nil."
1056 (let ((pub (eieio--class-public-a (eieio--object-class-object obj)))) 916 (let ((slots (eieio--class-slots (eieio--object-class obj))))
1057 (while pub 917 (dotimes (i (length slots))
1058 (let ((df (eieio-oref-default obj (car pub)))) 918 (let* ((name (cl--slot-descriptor-name (aref slots i)))
919 (df (eieio-oref-default obj name)))
1059 (if (or df set-all) 920 (if (or df set-all)
1060 (eieio-oset obj (car pub) df))) 921 (eieio-oset obj name df))))))
1061 (setq pub (cdr pub)))))
1062 922
1063(defun eieio--initarg-to-attribute (class initarg) 923(defun eieio--initarg-to-attribute (class initarg)
1064 "For CLASS, convert INITARG to the actual attribute name. 924 "For CLASS, convert INITARG to the actual attribute name.
@@ -1085,11 +945,8 @@ need be... May remove that later...)"
1085(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) 945(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
1086 "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. 946 "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
1087If a consistent order does not exist, signal an error." 947If a consistent order does not exist, signal an error."
1088 (if (let ((tail remaining-inputs) 948 (setq remaining-inputs (delq nil remaining-inputs))
1089 (found nil)) 949 (if (null remaining-inputs)
1090 (while (and tail (not found))
1091 (setq found (car tail) tail (cdr tail)))
1092 (not found))
1093 ;; If all remaining inputs are empty lists, we are done. 950 ;; If all remaining inputs are empty lists, we are done.
1094 (nreverse reversed-partial-result) 951 (nreverse reversed-partial-result)
1095 ;; Otherwise, we try to find the next element of the result. This 952 ;; 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."
1100 (tail remaining-inputs) 957 (tail remaining-inputs)
1101 (next (progn 958 (next (progn
1102 (while (and tail (not found)) 959 (while (and tail (not found))
1103 (setq found (and (car tail) 960 (setq found (eieio--c3-candidate (caar tail)
1104 (eieio--c3-candidate (caar tail) 961 remaining-inputs)
1105 remaining-inputs))
1106 tail (cdr tail))) 962 tail (cdr tail)))
1107 found))) 963 found)))
1108 (if next 964 (if next
@@ -1116,9 +972,13 @@ If a consistent order does not exist, signal an error."
1116 ;; The graph is inconsistent, give up 972 ;; The graph is inconsistent, give up
1117 (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) 973 (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
1118 974
975(defsubst eieio--class/struct-parents (class)
976 (or (eieio--class-parents class)
977 `(,eieio-default-superclass)))
978
1119(defun eieio--class-precedence-c3 (class) 979(defun eieio--class-precedence-c3 (class)
1120 "Return all parents of CLASS in c3 order." 980 "Return all parents of CLASS in c3 order."
1121 (let ((parents (eieio--class-parent (eieio--class-v class)))) 981 (let ((parents (eieio--class-parents (eieio--class-v class))))
1122 (eieio--c3-merge-lists 982 (eieio--c3-merge-lists
1123 (list class) 983 (list class)
1124 (append 984 (append
@@ -1132,7 +992,7 @@ If a consistent order does not exist, signal an error."
1132 992
1133(defun eieio--class-precedence-dfs (class) 993(defun eieio--class-precedence-dfs (class)
1134 "Return all parents of CLASS in depth-first order." 994 "Return all parents of CLASS in depth-first order."
1135 (let* ((parents (eieio--class-parent class)) 995 (let* ((parents (eieio--class-parents class))
1136 (classes (copy-sequence 996 (classes (copy-sequence
1137 (apply #'append 997 (apply #'append
1138 (list class) 998 (list class)
@@ -1155,15 +1015,13 @@ If a consistent order does not exist, signal an error."
1155(defun eieio--class-precedence-bfs (class) 1015(defun eieio--class-precedence-bfs (class)
1156 "Return all parents of CLASS in breadth-first order." 1016 "Return all parents of CLASS in breadth-first order."
1157 (let* ((result) 1017 (let* ((result)
1158 (queue (or (eieio--class-parent class) 1018 (queue (eieio--class/struct-parents class)))
1159 `(,eieio-default-superclass))))
1160 (while queue 1019 (while queue
1161 (let ((head (pop queue))) 1020 (let ((head (pop queue)))
1162 (unless (member head result) 1021 (unless (member head result)
1163 (push head result) 1022 (push head result)
1164 (unless (eq head eieio-default-superclass) 1023 (unless (eq head eieio-default-superclass)
1165 (setq queue (append queue (or (eieio--class-parent head) 1024 (setq queue (append queue (eieio--class/struct-parents head)))))))
1166 `(,eieio-default-superclass))))))))
1167 (cons class (nreverse result))) 1025 (cons class (nreverse result)))
1168 ) 1026 )
1169 1027
@@ -1177,7 +1035,7 @@ method invocation orders of the involved classes."
1177 (if (or (null class) (eq class eieio-default-superclass)) 1035 (if (or (null class) (eq class eieio-default-superclass))
1178 nil 1036 nil
1179 (unless (eieio--class-default-object-cache class) 1037 (unless (eieio--class-default-object-cache class)
1180 (eieio-class-un-autoload (eieio--class-symbol class))) 1038 (eieio-class-un-autoload (eieio--class-name class)))
1181 (cl-case (eieio--class-method-invocation-order class) 1039 (cl-case (eieio--class-method-invocation-order class)
1182 (:depth-first 1040 (:depth-first
1183 (eieio--class-precedence-dfs class)) 1041 (eieio--class-precedence-dfs class))
@@ -1211,7 +1069,7 @@ method invocation orders of the involved classes."
1211 50 #'cl--generic-struct-tag 1069 50 #'cl--generic-struct-tag
1212 (lambda (tag) 1070 (lambda (tag)
1213 (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) 1071 (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
1214 (mapcar #'eieio--class-symbol 1072 (mapcar #'eieio--class-name
1215 (eieio--class-precedence-list (symbol-value tag))))))) 1073 (eieio--class-precedence-list (symbol-value tag)))))))
1216 1074
1217(cl-defmethod cl-generic-generalizers :extra "class" (specializer) 1075(cl-defmethod cl-generic-generalizers :extra "class" (specializer)
@@ -1235,7 +1093,7 @@ method invocation orders of the involved classes."
1235(defun eieio--generic-subclass-specializers (tag) 1093(defun eieio--generic-subclass-specializers (tag)
1236 (when (eieio--class-p tag) 1094 (when (eieio--class-p tag)
1237 (mapcar (lambda (class) 1095 (mapcar (lambda (class)
1238 `(subclass ,(eieio--class-symbol class))) 1096 `(subclass ,(eieio--class-name class)))
1239 (eieio--class-precedence-list tag)))) 1097 (eieio--class-precedence-list tag))))
1240 1098
1241(defconst eieio--generic-subclass-generalizer 1099(defconst eieio--generic-subclass-generalizer
@@ -1247,7 +1105,7 @@ method invocation orders of the involved classes."
1247 (list eieio--generic-subclass-generalizer)) 1105 (list eieio--generic-subclass-generalizer))
1248 1106
1249 1107
1250;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "25a66814a400e7dea16bf0f3bfe245ed") 1108;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "0609a7bdcd6f38876b7f5647047ddca9")
1251;;; Generated autoloads from eieio-compat.el 1109;;; Generated autoloads from eieio-compat.el
1252 1110
1253(autoload 'eieio--defalias "eieio-compat" "\ 1111(autoload 'eieio--defalias "eieio-compat" "\
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 0e0b31e4e7e..26fc452f7b1 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -193,12 +193,8 @@ Optional argument IGNORE is an extraneous parameter."
193 (let* ((chil nil) 193 (let* ((chil nil)
194 (obj (widget-get widget :value)) 194 (obj (widget-get widget :value))
195 (master-group (widget-get widget :eieio-group)) 195 (master-group (widget-get widget :eieio-group))
196 (cv (eieio--object-class-object obj)) 196 (cv (eieio--object-class obj))
197 (slots (eieio--class-public-a cv)) 197 (slots (eieio--class-slots cv)))
198 (flabel (eieio--class-public-custom-label cv))
199 (fgroup (eieio--class-public-custom-group cv))
200 (fdoc (eieio--class-public-doc cv))
201 (fcust (eieio--class-public-custom cv)))
202 ;; First line describes the object, but may not editable. 198 ;; First line describes the object, but may not editable.
203 (if (widget-get widget :eieio-show-name) 199 (if (widget-get widget :eieio-show-name)
204 (setq chil (cons (widget-create-child-and-convert 200 (setq chil (cons (widget-create-child-and-convert
@@ -208,7 +204,7 @@ Optional argument IGNORE is an extraneous parameter."
208 chil))) 204 chil)))
209 ;; Display information about the group being shown 205 ;; Display information about the group being shown
210 (when master-group 206 (when master-group
211 (let ((groups (eieio--class-option (eieio--object-class-object obj) 207 (let ((groups (eieio--class-option (eieio--object-class obj)
212 :custom-groups))) 208 :custom-groups)))
213 (widget-insert "Groups:") 209 (widget-insert "Groups:")
214 (while groups 210 (while groups
@@ -225,63 +221,59 @@ Optional argument IGNORE is an extraneous parameter."
225 (setq groups (cdr groups))) 221 (setq groups (cdr groups)))
226 (widget-insert "\n\n"))) 222 (widget-insert "\n\n")))
227 ;; Loop over all the slots, creating child widgets. 223 ;; Loop over all the slots, creating child widgets.
228 (while slots 224 (dotimes (i (length slots))
229 ;; Output this slot if it has a customize flag associated with it. 225 (let* ((slot (aref slots i))
230 (when (and (car fcust) 226 (props (cl--slot-descriptor-props slot)))
231 (or (not master-group) (member master-group (car fgroup))) 227 ;; Output this slot if it has a customize flag associated with it.
232 (slot-boundp obj (car slots))) 228 (when (and (alist-get :custom props)
233 ;; In this case, this slot has a custom type. Create its 229 (or (not master-group)
234 ;; children widgets. 230 (member master-group (alist-get :group props)))
235 (let ((type (eieio-filter-slot-type widget (car fcust))) 231 (slot-boundp obj (cl--slot-descriptor-name slot)))
236 (stuff nil)) 232 ;; In this case, this slot has a custom type. Create its
237 ;; This next bit is an evil hack to get some EDE functions 233 ;; children widgets.
238 ;; working the way I like. 234 (let ((type (eieio-filter-slot-type widget (alist-get :custom props)))
239 (if (and (listp type) 235 (stuff nil))
240 (setq stuff (member :slotofchoices type))) 236 ;; This next bit is an evil hack to get some EDE functions
241 (let ((choices (eieio-oref obj (car (cdr stuff)))) 237 ;; working the way I like.
242 (newtype nil)) 238 (if (and (listp type)
243 (while (not (eq (car type) :slotofchoices)) 239 (setq stuff (member :slotofchoices type)))
244 (setq newtype (cons (car type) newtype) 240 (let ((choices (eieio-oref obj (car (cdr stuff))))
245 type (cdr type))) 241 (newtype nil))
246 (while choices 242 (while (not (eq (car type) :slotofchoices))
247 (setq newtype (cons (list 'const (car choices)) 243 (setq newtype (cons (car type) newtype)
248 newtype) 244 type (cdr type)))
249 choices (cdr choices))) 245 (while choices
250 (setq type (nreverse newtype)))) 246 (setq newtype (cons (list 'const (car choices))
251 (setq chil (cons (widget-create-child-and-convert 247 newtype)
252 widget 'object-slot 248 choices (cdr choices)))
253 :childtype type 249 (setq type (nreverse newtype))))
254 :sample-face 'eieio-custom-slot-tag-face 250 (setq chil (cons (widget-create-child-and-convert
255 :tag 251 widget 'object-slot
256 (concat 252 :childtype type
257 (make-string 253 :sample-face 'eieio-custom-slot-tag-face
258 (or (widget-get widget :indent) 0) 254 :tag
259 ? ) 255 (concat
260 (if (car flabel) 256 (make-string
261 (car flabel) 257 (or (widget-get widget :indent) 0)
262 (let ((s (symbol-name 258 ?\s)
263 (or 259 (or (alist-get :label props)
264 (eieio--class-slot-initarg 260 (let ((s (symbol-name
265 (eieio--object-class-object obj) 261 (or
266 (car slots)) 262 (eieio--class-slot-initarg
267 (car slots))))) 263 (eieio--object-class obj)
268 (capitalize 264 (car slots))
269 (if (string-match "^:" s) 265 (car slots)))))
270 (substring s (match-end 0)) 266 (capitalize
271 s))))) 267 (if (string-match "^:" s)
272 :value (slot-value obj (car slots)) 268 (substring s (match-end 0))
273 :doc (if (car fdoc) (car fdoc) 269 s)))))
274 "Slot not Documented.") 270 :value (slot-value obj (car slots))
275 :eieio-custom-visibility 'visible 271 :doc (or (alist-get :documentation props)
276 ) 272 "Slot not Documented.")
277 chil)) 273 :eieio-custom-visibility 'visible
278 ) 274 )
279 ) 275 chil))
280 (setq slots (cdr slots) 276 ))))
281 fdoc (cdr fdoc)
282 fcust (cdr fcust)
283 flabel (cdr flabel)
284 fgroup (cdr fgroup)))
285 (widget-put widget :children (nreverse chil)) 277 (widget-put widget :children (nreverse chil))
286 )) 278 ))
287 279
@@ -289,34 +281,33 @@ Optional argument IGNORE is an extraneous parameter."
289 "Get the value of WIDGET." 281 "Get the value of WIDGET."
290 (let* ((obj (widget-get widget :value)) 282 (let* ((obj (widget-get widget :value))
291 (master-group eieio-cog) 283 (master-group eieio-cog)
292 (cv (eieio--object-class-object obj))
293 (fgroup (eieio--class-public-custom-group cv))
294 (wids (widget-get widget :children)) 284 (wids (widget-get widget :children))
295 (name (if (widget-get widget :eieio-show-name) 285 (name (if (widget-get widget :eieio-show-name)
296 (car (widget-apply (car wids) :value-inline)) 286 (car (widget-apply (car wids) :value-inline))
297 nil)) 287 nil))
298 (chil (if (widget-get widget :eieio-show-name) 288 (chil (if (widget-get widget :eieio-show-name)
299 (nthcdr 1 wids) wids)) 289 (nthcdr 1 wids) wids))
300 (cv (eieio--object-class-object obj)) 290 (cv (eieio--object-class obj))
301 (slots (eieio--class-public-a cv)) 291 (i 0)
302 (fcust (eieio--class-public-custom cv))) 292 (slots (eieio--class-slots cv)))
303 ;; If there are any prefix widgets, clear them. 293 ;; If there are any prefix widgets, clear them.
304 ;; -- None yet 294 ;; -- None yet
305 ;; Create a batch of initargs for each slot. 295 ;; Create a batch of initargs for each slot.
306 (while (and slots chil) 296 (while (and (< i (length slots)) chil)
307 (if (and (car fcust) 297 (let* ((slot (aref slots i))
308 (or eieio-custom-ignore-eieio-co 298 (props (cl--slot-descriptor-props slot))
309 (not master-group) (member master-group (car fgroup))) 299 (cust (alist-get :custom props)))
310 (slot-boundp obj (car slots))) 300 (if (and cust
311 (progn 301 (or eieio-custom-ignore-eieio-co
312 ;; Only customized slots have widgets 302 (not master-group)
313 (let ((eieio-custom-ignore-eieio-co t)) 303 (member master-group (alist-get :group props)))
314 (eieio-oset obj (car slots) 304 (slot-boundp obj (cl--slot-descriptor-name slot)))
315 (car (widget-apply (car chil) :value-inline)))) 305 (progn
316 (setq chil (cdr chil)))) 306 ;; Only customized slots have widgets
317 (setq slots (cdr slots) 307 (let ((eieio-custom-ignore-eieio-co t))
318 fgroup (cdr fgroup) 308 (eieio-oset obj (cl--slot-descriptor-name slot)
319 fcust (cdr fcust))) 309 (car (widget-apply (car chil) :value-inline))))
310 (setq chil (cdr chil))))))
320 ;; Set any name updates on it. 311 ;; Set any name updates on it.
321 (if name (eieio-object-set-name-string obj name)) 312 (if name (eieio-object-set-name-string obj name))
322 ;; This is the same object we had before. 313 ;; This is the same object we had before.
@@ -452,7 +443,7 @@ Must return the created widget."
452 (vector (concat "Group " (symbol-name group)) 443 (vector (concat "Group " (symbol-name group))
453 (list 'customize-object obj (list 'quote group)) 444 (list 'customize-object obj (list 'quote group))
454 t)) 445 t))
455 (eieio--class-option (eieio--object-class-object obj) :custom-groups))) 446 (eieio--class-option (eieio--object-class obj) :custom-groups)))
456 447
457(defvar eieio-read-custom-group-history nil 448(defvar eieio-read-custom-group-history nil
458 "History for the custom group reader.") 449 "History for the custom group reader.")
@@ -460,7 +451,7 @@ Must return the created widget."
460(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass)) 451(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass))
461 "Do a completing read on the name of a customization group in OBJ. 452 "Do a completing read on the name of a customization group in OBJ.
462Return the symbol for the group, or nil" 453Return the symbol for the group, or nil"
463 (let ((g (eieio--class-option (eieio--object-class-object obj) 454 (let ((g (eieio--class-option (eieio--object-class obj)
464 :custom-groups))) 455 :custom-groups)))
465 (if (= (length g) 1) 456 (if (= (length g) 1)
466 (car g) 457 (car g)
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index 82349192e5e..c820180359b 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -31,6 +31,9 @@
31 31
32;;; Code: 32;;; Code:
33 33
34(declare-function data-debug/eieio-insert-slots "eieio-datadebug"
35 (obj eieio-default-superclass))
36
34(defun data-debug-insert-object-slots (object prefix) 37(defun data-debug-insert-object-slots (object prefix)
35 "Insert all the slots of OBJECT. 38 "Insert all the slots of OBJECT.
36PREFIX specifies what to insert at the start of each line." 39PREFIX 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."
54 "Insert a button representing OBJECT. 57 "Insert a button representing OBJECT.
55PREFIX is the text that precedes the button. 58PREFIX is the text that precedes the button.
56PREBUTTONTEXT is some text between PREFIX and the object button." 59PREBUTTONTEXT is some text between PREFIX and the object button."
57 (let ((start (point)) 60 (let* ((start (point))
58 (end nil) 61 (end nil)
59 (str (object-print object)) 62 (str (object-print object))
60 (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" 63 (class (eieio-object-class object))
61 (eieio-object-name-string object) 64 (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
62 (eieio-object-class object) 65 (eieio-object-name-string object)
63 (eieio-class-parents (eieio-object-class object)) 66 class
64 (length (object-slots object)) 67 (eieio-class-parents class)
65 )) 68 (length (eieio-class-slots class))
66 ) 69 ))
70 )
67 (insert prefix prebuttontext str) 71 (insert prefix prebuttontext str)
68 (setq end (point)) 72 (setq end (point))
69 (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face) 73 (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."
80;; Each object should have an opportunity to show stuff about itself. 84;; Each object should have an opportunity to show stuff about itself.
81 85
82(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) 86(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
83 prefix) 87 prefix)
84 "Insert the slots of OBJ into the current DDEBUG buffer." 88 "Insert the slots of OBJ into the current DDEBUG buffer."
85 (let ((inhibit-read-only t)) 89 (let ((inhibit-read-only t))
86 (data-debug-insert-thing (eieio-object-name-string obj) 90 (data-debug-insert-thing (eieio-object-name-string obj)
87 prefix 91 prefix
88 "Name: ") 92 "Name: ")
89 (let* ((cl (eieio-object-class obj)) 93 (let* ((cv (eieio--object-class obj)))
90 (cv (eieio--class-v cl))) 94 (data-debug-insert-thing (eieio--class-name cv)
91 (data-debug-insert-thing (eieio--class-constructor cl)
92 prefix 95 prefix
93 "Class: ") 96 "Class: ")
94 ;; Loop over all the public slots 97 ;; Loop over all the public slots
95 (let ((publa (eieio--class-public-a cv)) 98 (let ((slots (eieio--class-slots cv)))
96 ) 99 (dotimes (i (length slots))
97 (while publa 100 (let* ((slot (aref slots i))
98 (if (slot-boundp obj (car publa)) 101 (sname (cl--slot-descriptor-name slot))
99 (let* ((i (eieio--class-slot-initarg (eieio--class-v cl) 102 (i (eieio--class-slot-initarg cv sname))
100 (car publa))) 103 (sstr (concat (symbol-name (or i sname)) " ")))
101 (v (eieio-oref obj (car publa)))) 104 (if (slot-boundp obj sname)
102 (data-debug-insert-thing 105 (let* ((v (eieio-oref obj sname)))
103 v prefix (concat 106 (data-debug-insert-thing v prefix sstr))
104 (if i (symbol-name i) 107 ;; Unbound case
105 (symbol-name (car publa))) 108 (data-debug-insert-custom
106 " "))) 109 "#unbound" prefix sstr
107 ;; Unbound case 110 'font-lock-keyword-face)
108 (let ((i (eieio--class-slot-initarg (eieio--class-v cl) 111 )))))))
109 (car publa))))
110 (data-debug-insert-custom
111 "#unbound" prefix
112 (concat (if i (symbol-name i)
113 (symbol-name (car publa)))
114 " ")
115 'font-lock-keyword-face))
116 )
117 (setq publa (cdr publa)))))))
118 112
119;;; Augment the Data debug thing display list. 113;;; Augment the Data debug thing display list.
120(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing)) 114(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing))
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index a769ca7b536..7f98730340d 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -99,7 +99,7 @@ If CLASS is actually an object, then also display current values of that object.
99 (when pl 99 (when pl
100 (insert " Inherits from ") 100 (insert " Inherits from ")
101 (while (setq cur (pop pl)) 101 (while (setq cur (pop pl))
102 (setq cur (eieio--class-symbol cur)) 102 (setq cur (eieio--class-name cur))
103 (insert "`") 103 (insert "`")
104 (help-insert-xref-button (symbol-name cur) 104 (help-insert-xref-button (symbol-name cur)
105 'help-function cur) 105 'help-function cur)
@@ -136,74 +136,40 @@ If CLASS is actually an object, then also display current values of that object.
136 (or doc ""))) 136 (or doc "")))
137 (insert "\n\n"))))) 137 (insert "\n\n")))))
138 138
139(defun eieio--help-print-slot (slot)
140 (insert
141 (concat
142 (propertize "Slot: " 'face 'bold)
143 (prin1-to-string (cl--slot-descriptor-name slot))
144 (unless (eq (cl--slot-descriptor-type slot) t)
145 (concat " type = "
146 (prin1-to-string (cl--slot-descriptor-type slot))))
147 (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound)
148 (concat " default = "
149 (prin1-to-string (cl--slot-descriptor-initform slot))))
150 (when (alist-get :printer (cl--slot-descriptor-props slot))
151 (concat " printer = "
152 (prin1-to-string
153 (alist-get :printer (cl--slot-descriptor-props slot)))))
154 (when (alist-get :documentation (cl--slot-descriptor-props slot))
155 (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot))
156 "\n")))
157 "\n"))
158
139(defun eieio-help-class-slots (class) 159(defun eieio-help-class-slots (class)
140 "Print help description for the slots in CLASS. 160 "Print help description for the slots in CLASS.
141Outputs to the current buffer." 161Outputs to the current buffer."
142 (let* ((cv (eieio--class-v class)) 162 (let* ((cv (eieio--class-v class))
143 (docs (eieio--class-public-doc cv)) 163 (slots (eieio--class-slots cv))
144 (names (eieio--class-public-a cv)) 164 (cslots (eieio--class-class-slots cv)))
145 (deflt (eieio--class-public-d cv))
146 (types (eieio--class-public-type cv))
147 (publp (eieio--class-public-printer cv))
148 (i 0)
149 (prot (eieio--class-protection cv))
150 )
151 (insert (propertize "Instance Allocated Slots:\n\n" 165 (insert (propertize "Instance Allocated Slots:\n\n"
152 'face 'bold)) 166 'face 'bold))
153 (while names 167 (dotimes (i (length slots))
154 (insert 168 (eieio--help-print-slot (aref slots i)))
155 (concat 169 (when (> (length cslots) 0)
156 (when (car prot)
157 (propertize "Private " 'face 'bold))
158 (propertize "Slot: " 'face 'bold)
159 (prin1-to-string (car names))
160 (unless (eq (aref types i) t)
161 (concat " type = "
162 (prin1-to-string (aref types i))))
163 (unless (eq (car deflt) eieio-unbound)
164 (concat " default = "
165 (prin1-to-string (car deflt))))
166 (when (car publp)
167 (concat " printer = "
168 (prin1-to-string (car publp))))
169 (when (car docs)
170 (concat "\n " (car docs) "\n"))
171 "\n"))
172 (setq names (cdr names)
173 docs (cdr docs)
174 deflt (cdr deflt)
175 publp (cdr publp)
176 prot (cdr prot)
177 i (1+ i)))
178 (setq docs (eieio--class-class-allocation-doc cv)
179 names (eieio--class-class-allocation-a cv)
180 types (eieio--class-class-allocation-type cv)
181 i 0
182 prot (eieio--class-class-allocation-protection cv))
183 (when names
184 (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) 170 (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
185 (while names 171 (dotimes (i (length cslots))
186 (insert 172 (eieio--help-print-slot (aref cslots i)))))
187 (concat
188 (when (car prot)
189 "Private ")
190 "Slot: "
191 (prin1-to-string (car names))
192 (unless (eq (aref types i) t)
193 (concat " type = "
194 (prin1-to-string (aref types i))))
195 (condition-case nil
196 (let ((value (eieio-oref class (car names))))
197 (concat " value = "
198 (prin1-to-string value)))
199 (error nil))
200 (when (car docs)
201 (concat "\n\n " (car docs) "\n"))
202 "\n"))
203 (setq names (cdr names)
204 docs (cdr docs)
205 prot (cdr prot)
206 i (1+ i)))))
207 173
208(defun eieio-build-class-alist (&optional class instantiable-only buildlist) 174(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
209 "Return an alist of all currently active classes for completion purposes. 175 "Return an alist of all currently active classes for completion purposes.
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index cdf1992f9a5..4ba67693175 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -320,19 +320,21 @@ variable name of the same name as the slot."
320 (declare (indent 2) (debug (sexp sexp def-body))) 320 (declare (indent 2) (debug (sexp sexp def-body)))
321 (require 'cl-lib) 321 (require 'cl-lib)
322 ;; Transform the spec-list into a cl-symbol-macrolet spec-list. 322 ;; Transform the spec-list into a cl-symbol-macrolet spec-list.
323 (let ((mappings (mapcar (lambda (entry) 323 (macroexp-let2 nil object object
324 (let ((var (if (listp entry) (car entry) entry)) 324 `(cl-symbol-macrolet
325 (slot (if (listp entry) (cadr entry) entry))) 325 ,(mapcar (lambda (entry)
326 (list var `(slot-value ,object ',slot)))) 326 (let ((var (if (listp entry) (car entry) entry))
327 spec-list))) 327 (slot (if (listp entry) (cadr entry) entry)))
328 (append (list 'cl-symbol-macrolet mappings) 328 (list var `(slot-value ,object ',slot))))
329 body))) 329 spec-list)
330 ,@body)))
330 331
331;;; Simple generators, and query functions. None of these would do 332;;; Simple generators, and query functions. None of these would do
332;; well embedded into an object. 333;; well embedded into an object.
333;; 334;;
335
334(define-obsolete-function-alias 336(define-obsolete-function-alias
335 'object-class-fast #'eieio--object-class-name "24.4") 337 'object-class-fast #'eieio-object-class "24.4")
336 338
337(cl-defgeneric eieio-object-name-string (obj) 339(cl-defgeneric eieio-object-name-string (obj)
338 "Return a string which is OBJ's name." 340 "Return a string which is OBJ's name."
@@ -342,7 +344,7 @@ variable name of the same name as the slot."
342 "Return a printed representation for object OBJ. 344 "Return a printed representation for object OBJ.
343If EXTRA, include that in the string returned to represent the symbol." 345If EXTRA, include that in the string returned to represent the symbol."
344 (cl-check-type obj eieio-object) 346 (cl-check-type obj eieio-object)
345 (format "#<%s %s%s>" (eieio--object-class-name obj) 347 (format "#<%s %s%s>" (eieio-object-class obj)
346 (eieio-object-name-string obj) (or extra ""))) 348 (eieio-object-name-string obj) (or extra "")))
347(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") 349(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
348 350
@@ -370,7 +372,7 @@ If EXTRA, include that in the string returned to represent the symbol."
370 "Return the class struct defining OBJ." 372 "Return the class struct defining OBJ."
371 ;; FIXME: We say we return a "struct" but we return a symbol instead! 373 ;; FIXME: We say we return a "struct" but we return a symbol instead!
372 (cl-check-type obj eieio-object) 374 (cl-check-type obj eieio-object)
373 (eieio--object-class-name obj)) 375 (eieio--class-name (eieio--object-class obj)))
374(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") 376(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
375;; CLOS name, maybe? 377;; CLOS name, maybe?
376(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") 378(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."
378(defun eieio-object-class-name (obj) 380(defun eieio-object-class-name (obj)
379 "Return a Lisp like symbol name for OBJ's class." 381 "Return a Lisp like symbol name for OBJ's class."
380 (cl-check-type obj eieio-object) 382 (cl-check-type obj eieio-object)
381 (eieio-class-name (eieio--object-class-object obj))) 383 (eieio-class-name (eieio--object-class obj)))
382(define-obsolete-function-alias 384(define-obsolete-function-alias
383 'object-class-name 'eieio-object-class-name "24.4") 385 'object-class-name 'eieio-object-class-name "24.4")
384 386
@@ -386,7 +388,7 @@ If EXTRA, include that in the string returned to represent the symbol."
386 "Return parent classes to CLASS. (overload of variable). 388 "Return parent classes to CLASS. (overload of variable).
387 389
388The CLOS function `class-direct-superclasses' is aliased to this function." 390The CLOS function `class-direct-superclasses' is aliased to this function."
389 (eieio--class-parent (eieio--class-object class))) 391 (eieio--class-parents (eieio--class-object class)))
390 392
391(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") 393(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
392 394
@@ -414,13 +416,13 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
414 (setq class (eieio--class-object class)) 416 (setq class (eieio--class-object class))
415 (cl-check-type class eieio--class) 417 (cl-check-type class eieio--class)
416 (cl-check-type obj eieio-object) 418 (cl-check-type obj eieio-object)
417 (eq (eieio--object-class-object obj) class)) 419 (eq (eieio--object-class obj) class))
418 420
419(defun object-of-class-p (obj class) 421(defun object-of-class-p (obj class)
420 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." 422 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
421 (cl-check-type obj eieio-object) 423 (cl-check-type obj eieio-object)
422 ;; class will be checked one layer down 424 ;; class will be checked one layer down
423 (child-of-class-p (eieio--object-class-object obj) class)) 425 (child-of-class-p (eieio--object-class obj) class))
424;; Backwards compatibility 426;; Backwards compatibility
425(defalias 'obj-of-class-p 'object-of-class-p) 427(defalias 'obj-of-class-p 'object-of-class-p)
426 428
@@ -428,36 +430,36 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
428 "Return non-nil if CHILD class is a subclass of CLASS." 430 "Return non-nil if CHILD class is a subclass of CLASS."
429 (setq child (eieio--class-object child)) 431 (setq child (eieio--class-object child))
430 (cl-check-type child eieio--class) 432 (cl-check-type child eieio--class)
431 ;; `eieio-default-superclass' is never mentioned in eieio--class-parent, 433 ;; `eieio-default-superclass' is never mentioned in eieio--class-parents,
432 ;; so we have to special case it here. 434 ;; so we have to special case it here.
433 (or (eq class 'eieio-default-superclass) 435 (or (eq class 'eieio-default-superclass)
434 (let ((p nil)) 436 (let ((p nil))
435 (setq class (eieio--class-object class)) 437 (setq class (eieio--class-object class))
436 (cl-check-type class eieio--class) 438 (cl-check-type class eieio--class)
437 (while (and child (not (eq child class))) 439 (while (and child (not (eq child class)))
438 (setq p (append p (eieio--class-parent child)) 440 (setq p (append p (eieio--class-parents child))
439 child (pop p))) 441 child (pop p)))
440 (if child t)))) 442 (if child t))))
441 443
442(defun eieio-slot-descriptor-name (slot) slot) 444(defun eieio-slot-descriptor-name (slot)
445 (cl--slot-descriptor-name slot))
443 446
444(defun eieio-class-slots (class) 447(defun eieio-class-slots (class)
445 "Return list of slots available in instances of CLASS." 448 "Return list of slots available in instances of CLASS."
446 ;; FIXME: This only gives the instance slots and ignores the 449 ;; FIXME: This only gives the instance slots and ignores the
447 ;; class-allocated slots. 450 ;; class-allocated slots.
448 ;; FIXME: It only gives the slot's *names* rather than actual
449 ;; slot descriptors.
450 (setq class (eieio--class-object class)) 451 (setq class (eieio--class-object class))
451 (cl-check-type class eieio--class) 452 (cl-check-type class eieio--class)
452 (eieio--class-public-a class)) 453 (mapcar #'identity (eieio--class-slots class)))
453 454
454(defun object-slots (obj) 455(defun object-slots (obj)
455 "Return list of slots available in OBJ." 456 "Return list of slots available in OBJ."
456 (declare (obsolete eieio-class-slots "25.1")) 457 (declare (obsolete eieio-class-slots "25.1"))
457 (cl-check-type obj eieio-object) 458 (cl-check-type obj eieio-object)
458 (eieio-class-slots (eieio--object-class-object obj))) 459 (eieio-class-slots (eieio--object-class obj)))
459 460
460(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." 461(defun eieio--class-slot-initarg (class slot)
462 "Fetch from CLASS, SLOT's :initarg."
461 (cl-check-type class eieio--class) 463 (cl-check-type class eieio--class)
462 (let ((ia (eieio--class-initarg-tuples class)) 464 (let ((ia (eieio--class-initarg-tuples class))
463 (f nil)) 465 (f nil))
@@ -507,12 +509,18 @@ OBJECT can be an instance or a class."
507(defun slot-exists-p (object-or-class slot) 509(defun slot-exists-p (object-or-class slot)
508 "Return non-nil if OBJECT-OR-CLASS has SLOT." 510 "Return non-nil if OBJECT-OR-CLASS has SLOT."
509 (let ((cv (cond ((eieio-object-p object-or-class) 511 (let ((cv (cond ((eieio-object-p object-or-class)
510 (eieio--object-class-object object-or-class)) 512 (eieio--object-class object-or-class))
511 ((eieio--class-p object-or-class) object-or-class) 513 ((eieio--class-p object-or-class) object-or-class)
512 (t (find-class object-or-class 'error))))) 514 (t (find-class object-or-class 'error)))))
513 (or (memq slot (eieio--class-public-a cv)) 515 (or (gethash slot (eieio--class-index-table cv))
514 (memq slot (eieio--class-class-allocation-a cv))) 516 ;; FIXME: We could speed this up by adding class slots into the
515 )) 517 ;; index-table (e.g. with a negative index?).
518 (let ((cs (eieio--class-class-slots cv))
519 found)
520 (dotimes (i (length cs))
521 (if (eq slot (cl--slot-descriptor-name (aref cs i)))
522 (setq found t)))
523 found))))
516 524
517(defun find-class (symbol &optional errorp) 525(defun find-class (symbol &optional errorp)
518 "Return the class that SYMBOL represents. 526 "Return the class that SYMBOL represents.
@@ -671,7 +679,7 @@ Called from the constructor routine.")
671 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 679 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
672Called from the constructor routine." 680Called from the constructor routine."
673 (while slots 681 (while slots
674 (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) 682 (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj)
675 (car slots)))) 683 (car slots))))
676 (if (not rn) 684 (if (not rn)
677 (slot-missing obj (car slots) 'oset (car (cdr slots))) 685 (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
694dynamically set from SLOTS." 702dynamically set from SLOTS."
695 ;; First, see if any of our defaults are `lambda', and 703 ;; First, see if any of our defaults are `lambda', and
696 ;; re-evaluate them and apply the value to our slots. 704 ;; re-evaluate them and apply the value to our slots.
697 (let* ((this-class (eieio--object-class-object this)) 705 (let* ((this-class (eieio--object-class this))
698 (defaults (eieio--class-public-d this-class))) 706 (slots (eieio--class-slots this-class)))
699 (dolist (slot (eieio--class-public-a this-class)) 707 (dotimes (i (length slots))
700 ;; For each slot, see if we need to evaluate it. 708 ;; For each slot, see if we need to evaluate it.
701 ;; 709 ;;
702 ;; Paul Landes said in an email: 710 ;; Paul Landes said in an email:
@@ -704,11 +712,12 @@ dynamically set from SLOTS."
704 ;; > the quoted thing as you already have. This is by the 712 ;; > the quoted thing as you already have. This is by the
705 ;; > Sonya E. Keene book and other things I've look at on the 713 ;; > Sonya E. Keene book and other things I've look at on the
706 ;; > web. 714 ;; > web.
707 (let ((dflt (eieio-default-eval-maybe (car defaults)))) 715 (let* ((slot (aref slots i))
708 (when (not (eq dflt (car defaults))) 716 (initform (cl--slot-descriptor-initform slot))
709 (eieio-oset this slot dflt) )) 717 (dflt (eieio-default-eval-maybe initform)))
710 ;; Next. 718 (when (not (eq dflt initform))
711 (setq defaults (cdr defaults)))) 719 ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)!
720 (eieio-oset this (cl--slot-descriptor-name slot) dflt)))))
712 ;; Shared initialize will parse our slots for us. 721 ;; Shared initialize will parse our slots for us.
713 (shared-initialize this slots)) 722 (shared-initialize this slots))
714 723
@@ -825,32 +834,31 @@ this object."
825 (prin1 (eieio-object-name-string this)) 834 (prin1 (eieio-object-name-string this))
826 (princ "\n") 835 (princ "\n")
827 ;; Loop over all the public slots 836 ;; Loop over all the public slots
828 (let ((publa (eieio--class-public-a cv)) 837 (let ((slots (eieio--class-slots cv))
829 (publd (eieio--class-public-d cv))
830 (publp (eieio--class-public-printer cv))
831 (eieio-print-depth (1+ eieio-print-depth))) 838 (eieio-print-depth (1+ eieio-print-depth)))
832 (while publa 839 (dotimes (i (length slots))
833 (when (slot-boundp this (car publa)) 840 (let ((slot (aref slots i)))
834 (let ((i (eieio--class-slot-initarg cv (car publa))) 841 (when (slot-boundp this (cl--slot-descriptor-name slot))
835 (v (eieio-oref this (car publa))) 842 (let ((i (eieio--class-slot-initarg
836 ) 843 cv (cl--slot-descriptor-name slot)))
837 (unless (or (not i) (equal v (car publd))) 844 (v (eieio-oref this (cl--slot-descriptor-name slot))))
838 (unless (bolp) 845 (unless (or (not i) (equal v (cl--slot-descriptor-initform slot)))
839 (princ "\n")) 846 (unless (bolp)
840 (princ (make-string (* eieio-print-depth 2) ? )) 847 (princ "\n"))
841 (princ (symbol-name i)) 848 (princ (make-string (* eieio-print-depth 2) ? ))
842 (if (car publp) 849 (princ (symbol-name i))
843 ;; Use our public printer 850 (if (alist-get :printer (cl--slot-descriptor-props slot))
844 (progn 851 ;; Use our public printer
845 (princ " ") 852 (progn
846 (funcall (car publp) v)) 853 (princ " ")
847 ;; Use our generic override prin1 function. 854 (funcall (alist-get :printer
848 (princ (if (or (eieio-object-p v) 855 (cl--slot-descriptor-props slot))
849 (eieio-object-p (car-safe v))) 856 v))
850 "\n" " ")) 857 ;; Use our generic override prin1 function.
851 (eieio-override-prin1 v))))) 858 (princ (if (or (eieio-object-p v)
852 (setq publa (cdr publa) publd (cdr publd) 859 (eieio-object-p (car-safe v)))
853 publp (cdr publp)))) 860 "\n" " "))
861 (eieio-override-prin1 v))))))))
854 (princ ")") 862 (princ ")")
855 (when (= eieio-print-depth 0) 863 (when (= eieio-print-depth 0)
856 (princ "\n")))) 864 (princ "\n"))))
@@ -919,7 +927,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
919 927
920;;; Start of automatically extracted autoloads. 928;;; Start of automatically extracted autoloads.
921 929
922;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2ec91e473fcad1ff20cd76edc4aab706") 930;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "813d32fbf76d4248fc6b4dc97ebcd720")
923;;; Generated autoloads from eieio-custom.el 931;;; Generated autoloads from eieio-custom.el
924 932
925(autoload 'customize-object "eieio-custom" "\ 933(autoload 'customize-object "eieio-custom" "\
@@ -930,7 +938,7 @@ Optional argument GROUP is the sub-group of slots to display.
930 938
931;;;*** 939;;;***
932 940
933;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d1910eb455f102989fc33bb3f5a9b614") 941;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "3005b815c6b30eccbf0642170b3f82a5")
934;;; Generated autoloads from eieio-opt.el 942;;; Generated autoloads from eieio-opt.el
935 943
936(autoload 'eieio-browse "eieio-opt" "\ 944(autoload 'eieio-browse "eieio-opt" "\
diff --git a/test/ChangeLog b/test/ChangeLog
index e150aba2874..15408a3c970 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,16 @@
12015-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/eieio-tests.el (eieio-test-17-virtual-slot): Don't use
4 initarg in `oset'.
5 (eieio-test-32-slot-attribute-override-2): Adjust to new
6 slot representation.
7
8 * automated/eieio-test-persist.el (persist-test-save-and-compare):
9 Adjust to new slot representation.
10
11 * automated/eieio-test-methodinvoke.el (make-instance): Use new-style
12 `subclass' specializer for a change.
13
12015-03-17 Stefan Monnier <monnier@iro.umontreal.ca> 142015-03-17 Stefan Monnier <monnier@iro.umontreal.ca>
2 15
3 * automated/cl-lib-tests.el: Use lexical-binding. 16 * automated/cl-lib-tests.el: Use lexical-binding.
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el
index 62f5603d3b6..5263013434e 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -184,7 +184,7 @@
184 (if (next-method-p) (call-next-method)) 184 (if (next-method-p) (call-next-method))
185 ) 185 )
186 186
187(defmethod make-instance :STATIC ((p C) &rest args) 187(cl-defmethod make-instance ((p (subclass C)) &rest args)
188 (eieio-test-method-store :STATIC 'C) 188 (eieio-test-method-store :STATIC 'C)
189 (call-next-method) 189 (call-next-method)
190 ) 190 )
diff --git a/test/automated/eieio-test-persist.el b/test/automated/eieio-test-persist.el
index 7bb2f1ca779..6710ead2e77 100644
--- a/test/automated/eieio-test-persist.el
+++ b/test/automated/eieio-test-persist.el
@@ -45,20 +45,20 @@ This is usually a symbol that starts with `:'."
45 45
46 (eieio-persistent-save original) 46 (eieio-persistent-save original)
47 47
48 (let* ((file (oref original :file)) 48 (let* ((file (oref original file))
49 (class (eieio-object-class original)) 49 (class (eieio-object-class original))
50 (fromdisk (eieio-persistent-read file class)) 50 (fromdisk (eieio-persistent-read file class))
51 (cv (eieio--class-v class)) 51 (cv (eieio--class-v class))
52 (slot-names (eieio--class-public-a cv)) 52 (slots (eieio--class-slots cv))
53 (slot-deflt (eieio--class-public-d cv))
54 ) 53 )
55 (unless (object-of-class-p fromdisk class) 54 (unless (object-of-class-p fromdisk class)
56 (error "Persistent class %S != original class %S" 55 (error "Persistent class %S != original class %S"
57 (eieio-object-class fromdisk) 56 (eieio-object-class fromdisk)
58 class)) 57 class))
59 58
60 (while slot-names 59 (dotimes (i (length slots))
61 (let* ((oneslot (car slot-names)) 60 (let* ((slot (aref slots i))
61 (oneslot (cl--slot-descriptor-name slot))
62 (origvalue (eieio-oref original oneslot)) 62 (origvalue (eieio-oref original oneslot))
63 (fromdiskvalue (eieio-oref fromdisk oneslot)) 63 (fromdiskvalue (eieio-oref fromdisk oneslot))
64 (initarg-p (eieio--attribute-to-initarg 64 (initarg-p (eieio--attribute-to-initarg
@@ -70,12 +70,9 @@ This is usually a symbol that starts with `:'."
70 (error "Slot %S Original Val %S != Persistent Val %S" 70 (error "Slot %S Original Val %S != Persistent Val %S"
71 oneslot origvalue fromdiskvalue)) 71 oneslot origvalue fromdiskvalue))
72 ;; Else !initarg-p 72 ;; Else !initarg-p
73 (unless (equal (car slot-deflt) fromdiskvalue) 73 (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue)
74 (error "Slot %S Persistent Val %S != Default Value %S" 74 (error "Slot %S Persistent Val %S != Default Value %S"
75 oneslot fromdiskvalue (car slot-deflt)))) 75 oneslot fromdiskvalue (cl--slot-descriptor-initform slot))))
76
77 (setq slot-names (cdr slot-names)
78 slot-deflt (cdr slot-deflt))
79 )))) 76 ))))
80 77
81;;; Simple Case 78;;; Simple Case
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el
index 7532609c4c3..01131d886dd 100644
--- a/test/automated/eieio-tests.el
+++ b/test/automated/eieio-tests.el
@@ -406,21 +406,21 @@ METHOD is the method that was attempting to be called."
406(ert-deftest eieio-test-17-virtual-slot () 406(ert-deftest eieio-test-17-virtual-slot ()
407 (setq eitest-vsca (virtual-slot-class :base-value 1)) 407 (setq eitest-vsca (virtual-slot-class :base-value 1))
408 ;; Check slot values 408 ;; Check slot values
409 (should (= (oref eitest-vsca :base-value) 1)) 409 (should (= (oref eitest-vsca base-value) 1))
410 (should (= (oref eitest-vsca :derived-value) 2)) 410 (should (= (oref eitest-vsca :derived-value) 2))
411 411
412 (oset eitest-vsca :derived-value 3) 412 (oset eitest-vsca derived-value 3)
413 (should (= (oref eitest-vsca :base-value) 2)) 413 (should (= (oref eitest-vsca base-value) 2))
414 (should (= (oref eitest-vsca :derived-value) 3)) 414 (should (= (oref eitest-vsca :derived-value) 3))
415 415
416 (oset eitest-vsca :base-value 3) 416 (oset eitest-vsca base-value 3)
417 (should (= (oref eitest-vsca :base-value) 3)) 417 (should (= (oref eitest-vsca base-value) 3))
418 (should (= (oref eitest-vsca :derived-value) 4)) 418 (should (= (oref eitest-vsca :derived-value) 4))
419 419
420 ;; should also be possible to initialize instance using virtual slot 420 ;; should also be possible to initialize instance using virtual slot
421 421
422 (setq eitest-vscb (virtual-slot-class :derived-value 5)) 422 (setq eitest-vscb (virtual-slot-class :derived-value 5))
423 (should (= (oref eitest-vscb :base-value) 4)) 423 (should (= (oref eitest-vscb base-value) 4))
424 (should (= (oref eitest-vscb :derived-value) 5))) 424 (should (= (oref eitest-vscb :derived-value) 5)))
425 425
426(ert-deftest eieio-test-18-slot-unbound () 426(ert-deftest eieio-test-18-slot-unbound ()
@@ -560,7 +560,8 @@ METHOD is the method that was attempting to be called."
560 (setq eitest-t1 (class-c)) 560 (setq eitest-t1 (class-c))
561 ;; Slot initialization 561 ;; Slot initialization
562 (should (eq (oref eitest-t1 slot-1) 'moose)) 562 (should (eq (oref eitest-t1 slot-1) 'moose))
563 (should (eq (oref eitest-t1 :moose) 'moose)) 563 ;; Accessing via the initarg name is deprecated!
564 ;; (should (eq (oref eitest-t1 :moose) 'moose))
564 ;; Don't pass reference of private slot 565 ;; Don't pass reference of private slot
565 ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) 566 ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
566 ;; Check private slot accessor 567 ;; Check private slot accessor
@@ -580,7 +581,8 @@ METHOD is the method that was attempting to be called."
580 ;; See previous test, nor for subclass 581 ;; See previous test, nor for subclass
581 (setq eitest-t2 (class-subc)) 582 (setq eitest-t2 (class-subc))
582 (should (eq (oref eitest-t2 slot-1) 'moose)) 583 (should (eq (oref eitest-t2 slot-1) 'moose))
583 (should (eq (oref eitest-t2 :moose) 'moose)) 584 ;; Accessing via the initarg name is deprecated!
585 ;;(should (eq (oref eitest-t2 :moose) 'moose))
584 (should (string= (get-slot-2 eitest-t2) "linux")) 586 (should (string= (get-slot-2 eitest-t2) "linux"))
585 ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) 587 ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
586 (should (string= (get-slot-2 eitest-t2) "linux")) 588 (should (string= (get-slot-2 eitest-t2) "linux"))
@@ -802,30 +804,24 @@ Subclasses to override slot attributes.")
802 804
803(ert-deftest eieio-test-32-slot-attribute-override-2 () 805(ert-deftest eieio-test-32-slot-attribute-override-2 ()
804 (let* ((cv (eieio--class-v 'slotattr-ok)) 806 (let* ((cv (eieio--class-v 'slotattr-ok))
805 (docs (eieio--class-public-doc cv)) 807 (slots (eieio--class-slots cv))
806 (names (eieio--class-public-a cv)) 808 (args (eieio--class-initarg-tuples cv)))
807 (cust (eieio--class-public-custom cv))
808 (label (eieio--class-public-custom-label cv))
809 (group (eieio--class-public-custom-group cv))
810 (types (eieio--class-public-type cv))
811 (args (eieio--class-initarg-tuples cv))
812 (i 0))
813 ;; :initarg should override for subclass 809 ;; :initarg should override for subclass
814 (should (assoc :initblarg args)) 810 (should (assoc :initblarg args))
815 811
816 (while (< i (length names)) 812 (dotimes (i (length slots))
817 (cond 813 (let* ((slot (aref slots i))
818 ((eq (nth i names) 'custom) 814 (props (cl--slot-descriptor-props slot)))
819 ;; Custom slot attributes must override 815 (cond
820 (should (eq (nth i cust) 'string)) 816 ((eq (cl--slot-descriptor-name slot) 'custom)
821 ;; Custom label slot attribute must override 817 ;; Custom slot attributes must override
822 (should (string= (nth i label) "One String")) 818 (should (eq (alist-get :custom props) 'string))
823 (let ((grp (nth i group))) 819 ;; Custom label slot attribute must override
824 ;; Custom group slot attribute must combine 820 (should (string= (alist-get :label props) "One String"))
825 (should (and (memq 'moose grp) (memq 'cow grp))))) 821 (let ((grp (alist-get :group props)))
826 (t nil)) 822 ;; Custom group slot attribute must combine
827 823 (should (and (memq 'moose grp) (memq 'cow grp)))))
828 (setq i (1+ i))))) 824 (t nil))))))
829 825
830(defvar eitest-CLONETEST1 nil) 826(defvar eitest-CLONETEST1 nil)
831(defvar eitest-CLONETEST2 nil) 827(defvar eitest-CLONETEST2 nil)
@@ -891,8 +887,7 @@ Subclasses to override slot attributes.")
891 (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) 887 (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
892 (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) 888 (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
893 889
894(defclass eieio--testing () 890(defclass eieio--testing () ())
895 ())
896 891
897(defmethod constructor :static ((_x eieio--testing) newname &rest _args) 892(defmethod constructor :static ((_x eieio--testing) newname &rest _args)
898 (list newname 2)) 893 (list newname 2))
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-23 11:31:21 +0000