aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2015-01-04 23:11:37 -0500
committerStefan Monnier2015-01-04 23:11:37 -0500
commitcb4db863192aed6c4d0b28e6490f08d5518ff3e7 (patch)
tree5d8e5dd834b7a3991e61631fcfcc209a7a25416e
parent232823a1f163cebeafdab20ea2eb3f2da9645185 (diff)
downloademacs-cb4db863192aed6c4d0b28e6490f08d5518ff3e7.tar.gz
emacs-cb4db863192aed6c4d0b28e6490f08d5518ff3e7.zip
* lisp/emacs-lisp/eieio*.el: Use class objects in `parent' field.
* lisp/emacs-lisp/eieio-core.el (eieio-class-object): New function. (eieio-class-parents-fast): Remove macro. (eieio--class-option-assoc): Rename from class-option-assoc. Update all callers. (eieio--class-option): Rename from class-option. Change `class' arg to be a class object. Update all callers. (eieio--class-method-invocation-order): Rename from class-method-invocation-order. Change `class' arg to be a class object. Update all callers. (eieio-defclass-autoload, eieio-defclass): Set the `parent' field to a list of class objects rather than names. (eieio-defclass): Remove redundant quotes. Use `eieio-oref-default' for accessors to class allocated slots. (eieio--perform-slot-validation-for-default): Rename from eieio-perform-slot-validation-for-default. Update all callers. (eieio--add-new-slot): Rename from eieio-add-new-slot. Update all callers. Use push. (eieio-copy-parents-into-subclass): Adjust to new content of `parent' field. Use dolist. (eieio-oref): Remove support for providing a class rather than an object. (eieio-oref-default): Prefer class objects over class names. (eieio--slot-originating-class-p): Rename from eieio-slot-originating-class-p. Update all callers. Use `or'. (eieio--slot-name-index): Turn check into assertion. (eieio--class-slot-name-index): Rename from eieio-class-slot-name-index. Change `class' arg to be a class object. Update all callers. (eieio-attribute-to-initarg): Move to eieio-test-persist.el. (eieio--c3-candidate): Rename from eieio-c3-candidate. Update all callers. (eieio--c3-merge-lists): Rename from eieio-c3-merge-lists. Update all callers. (eieio--class-precedence-c3): Rename from eieio-class-precedence-c3. Update all callers. (eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs. Update all callers. (eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs. Update all callers. Adjust to new `parent' content. (eieio--class-precedence-list): Rename from -class-precedence-list. Update all callers. (eieio-generic-call): Use autoloadp and autoload-do-load. Slight simplification. (eieio-generic-call, eieio-generic-call-primary-only): Adjust to new return value of `eieio-generic-form'. (eieiomt-add): Index the hashtable with class objects rather than class names. (eieio-generic-form): Accept class objects as well. * lisp/emacs-lisp/eieio.el (eieio-class-parents): Accept class objects. (eieio--class-slot-initarg): Rename from class-slot-initarg. Change `class' arg to be a class object. Update all callers. (call-next-method): Adjust to new return value of `eieio-generic-form'. (eieio-default-superclass): Set var to the class object. (eieio-edebug-prin1-to-string): Fix recursive call for lists. Change print behavior to affect class objects rather than class symbols. * lisp/emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object): Adjust to new convention for eieio-persistent-validate/fix-slot-value. (eieio-persistent-validate/fix-slot-value): Change `class' arg to be a class object. Update all callers. * test/automated/eieio-test-persist.el (eieio--attribute-to-initarg): Move from eieio-core.el. Rename from eieio-attribute-to-initarg. Change arg to be a class object. Update all callers. * test/automated/eieio-tests.el (eieio-test-04-static-method) (eieio-test-05-static-method-2): Use oref-default to access class slots. (eieio-test-23-inheritance-check): Don't assume that eieio-class-parents returns class names, or that a class can only have a single name.
-rw-r--r--lisp/ChangeLog65
-rw-r--r--lisp/emacs-lisp/eieio-base.el6
-rw-r--r--lisp/emacs-lisp/eieio-core.el443
-rw-r--r--lisp/emacs-lisp/eieio-custom.el13
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el6
-rw-r--r--lisp/emacs-lisp/eieio-opt.el2
-rw-r--r--lisp/emacs-lisp/eieio.el41
-rw-r--r--test/ChangeLog13
-rw-r--r--test/automated/eieio-test-persist.el11
-rw-r--r--test/automated/eieio-tests.el14
10 files changed, 357 insertions, 257 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 209c833fbe3..971253b3014 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,68 @@
12015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
4 (eieio--class-slot-initarg): Rename from class-slot-initarg.
5 Change `class' arg to be a class object. Update all callers.
6 (call-next-method): Adjust to new return value of `eieio-generic-form'.
7 (eieio-default-superclass): Set var to the class object.
8 (eieio-edebug-prin1-to-string): Fix recursive call for lists.
9 Change print behavior to affect class objects rather than
10 class symbols.
11
12 * emacs-lisp/eieio-core.el (eieio-class-object): New function.
13 (eieio-class-parents-fast): Remove macro.
14 (eieio--class-option-assoc): Rename from class-option-assoc.
15 Update all callers.
16 (eieio--class-option): Rename from class-option. Change `class' arg to
17 be a class object. Update all callers.
18 (eieio--class-method-invocation-order): Rename from
19 class-method-invocation-order. Change `class' arg to be a class
20 object. Update all callers.
21 (eieio-defclass-autoload, eieio-defclass): Set the `parent' field to
22 a list of class objects rather than names.
23 (eieio-defclass): Remove redundant quotes. Use `eieio-oref-default'
24 for accessors to class allocated slots.
25 (eieio--perform-slot-validation-for-default): Rename from
26 eieio-perform-slot-validation-for-default. Update all callers.
27 (eieio--add-new-slot): Rename from eieio-add-new-slot.
28 Update all callers. Use push.
29 (eieio-copy-parents-into-subclass): Adjust to new content of
30 `parent' field. Use dolist.
31 (eieio-oref): Remove support for providing a class rather than
32 an object.
33 (eieio-oref-default): Prefer class objects over class names.
34 (eieio--slot-originating-class-p): Rename from
35 eieio-slot-originating-class-p. Update all callers. Use `or'.
36 (eieio--slot-name-index): Turn check into assertion.
37 (eieio--class-slot-name-index): Rename from
38 eieio-class-slot-name-index. Change `class' arg to be a class object.
39 Update all callers.
40 (eieio-attribute-to-initarg): Move to eieio-test-persist.el.
41 (eieio--c3-candidate): Rename from eieio-c3-candidate.
42 Update all callers.
43 (eieio--c3-merge-lists): Rename from eieio-c3-merge-lists.
44 Update all callers.
45 (eieio--class-precedence-c3): Rename from eieio-class-precedence-c3.
46 Update all callers.
47 (eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs.
48 Update all callers.
49 (eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs.
50 Update all callers. Adjust to new `parent' content.
51 (eieio--class-precedence-list): Rename from -class-precedence-list.
52 Update all callers.
53 (eieio-generic-call): Use autoloadp and autoload-do-load.
54 Slight simplification.
55 (eieio-generic-call, eieio-generic-call-primary-only): Adjust to new
56 return value of `eieio-generic-form'.
57 (eieiomt-add): Index the hashtable with class objects rather than
58 class names.
59 (eieio-generic-form): Accept class objects as well.
60
61 * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
62 Adjust to new convention for eieio-persistent-validate/fix-slot-value.
63 (eieio-persistent-validate/fix-slot-value):
64 Change `class' arg to be a class object. Update all callers.
65
12014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> 662014-12-29 Stefan Monnier <monnier@iro.umontreal.ca>
2 67
3 * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects 68 * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index e841ed664c0..7c0161b25d2 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -270,7 +270,7 @@ identified, and needing more object creation."
270 ;; In addition, strip out quotes, list functions, and update 270 ;; In addition, strip out quotes, list functions, and update
271 ;; object constructors as needed. 271 ;; object constructors as needed.
272 (setq value (eieio-persistent-validate/fix-slot-value 272 (setq value (eieio-persistent-validate/fix-slot-value
273 objclass name value)) 273 (eieio--class-v objclass) name value))
274 274
275 (push name createslots) 275 (push name createslots)
276 (push value createslots) 276 (push value createslots)
@@ -290,13 +290,13 @@ constructor functions are considered valid.
290Second, any text properties will be stripped from strings." 290Second, any text properties will be stripped from strings."
291 (cond ((consp proposed-value) 291 (cond ((consp proposed-value)
292 ;; Lists with something in them need special treatment. 292 ;; Lists with something in them need special treatment.
293 (let ((slot-idx (eieio--slot-name-index (eieio--class-v class) 293 (let ((slot-idx (eieio--slot-name-index class
294 nil slot)) 294 nil slot))
295 (type nil) 295 (type nil)
296 (classtype nil)) 296 (classtype nil))
297 (setq slot-idx (- slot-idx 297 (setq slot-idx (- slot-idx
298 (eval-when-compile eieio--object-num-slots))) 298 (eval-when-compile eieio--object-num-slots)))
299 (setq type (aref (eieio--class-public-type (eieio--class-v class)) 299 (setq type (aref (eieio--class-public-type class)
300 slot-idx)) 300 slot-idx))
301 301
302 (setq classtype (eieio-persistent-slot-type-is-class-p 302 (setq classtype (eieio-persistent-slot-type-is-class-p
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 924886c5ba1..950d70f450a 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -1,6 +1,6 @@
1;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- 1;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. 3;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
4 4
5;; Author: Eric M. Ludlam <zappo@gnu.org> 5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Version: 1.4 6;; Version: 1.4
@@ -225,6 +225,12 @@ Stored outright without modifications or stripping.")))
225 (eq (aref class 0) 'defclass) 225 (eq (aref class 0) 'defclass)
226 (error nil))) 226 (error nil)))
227 227
228(defsubst eieio-class-object (class)
229 "Check that CLASS is a class and return the corresponding object."
230 (let ((c (eieio--class-object class)))
231 (eieio--check-type eieio--class-p c)
232 c))
233
228(defsubst class-p (class) 234(defsubst class-p (class)
229 "Return non-nil if CLASS is a valid class vector. 235 "Return non-nil if CLASS is a valid class vector.
230CLASS is a symbol." ;FIXME: Is it a vector or a symbol? 236CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
@@ -238,17 +244,16 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
238 "Return a Lisp like symbol name for CLASS." 244 "Return a Lisp like symbol name for CLASS."
239 ;; FIXME: What's a "Lisp like symbol name"? 245 ;; FIXME: What's a "Lisp like symbol name"?
240 ;; FIXME: CLOS returns a symbol, but the code returns a string. 246 ;; FIXME: CLOS returns a symbol, but the code returns a string.
247 (if (eieio--class-p class) (setq class (eieio--class-symbol class)))
241 (eieio--check-type class-p class) 248 (eieio--check-type class-p class)
242 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, 249 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol,
243 ;; and I wanted a string. Arg! 250 ;; and I wanted a string. Arg!
244 (format "#<class %s>" (symbol-name class))) 251 (format "#<class %s>" (symbol-name class)))
245(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") 252(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
246 253
247(defmacro eieio-class-parents-fast (class)
248 "Return parent classes to CLASS with no check."
249 `(eieio--class-parent (eieio--class-v ,class)))
250
251(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." 254(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check."
255 ;; FIXME: Remove. And change `children' to contain class objects rather than
256 ;; class names.
252 `(eieio--class-children (eieio--class-v ,class))) 257 `(eieio--class-children (eieio--class-v ,class)))
253 258
254(defsubst same-class-fast-p (obj class-name) 259(defsubst same-class-fast-p (obj class-name)
@@ -299,14 +304,14 @@ Methods with only primary implementations are executed in an optimized way."
299 (aref M eieio--method-generic-after))) 304 (aref M eieio--method-generic-after)))
300 ))) 305 )))
301 306
302(defmacro class-option-assoc (list option) 307(defmacro eieio--class-option-assoc (list option)
303 "Return from LIST the found OPTION, or nil if it doesn't exist." 308 "Return from LIST the found OPTION, or nil if it doesn't exist."
304 `(car-safe (cdr (memq ,option ,list)))) 309 `(car-safe (cdr (memq ,option ,list))))
305 310
306(defmacro class-option (class option) 311(defsubst eieio--class-option (class option)
307 "Return the value stored for CLASS' OPTION. 312 "Return the value stored for CLASS' OPTION.
308Return nil if that option doesn't exist." 313Return nil if that option doesn't exist."
309 `(class-option-assoc (eieio--class-options (eieio--class-v ,class)) ',option)) 314 (eieio--class-option-assoc (eieio--class-options class) option))
310 315
311(defsubst eieio-object-p (obj) 316(defsubst eieio-object-p (obj)
312 "Return non-nil if OBJ is an EIEIO object." 317 "Return non-nil if OBJ is an EIEIO object."
@@ -320,13 +325,13 @@ Return nil if that option doesn't exist."
320(defsubst class-abstract-p (class) 325(defsubst class-abstract-p (class)
321 "Return non-nil if CLASS is abstract. 326 "Return non-nil if CLASS is abstract.
322Abstract classes cannot be instantiated." 327Abstract classes cannot be instantiated."
323 (class-option class :abstract)) 328 (eieio--class-option (eieio--class-v class) :abstract))
324 329
325(defmacro class-method-invocation-order (class) 330(defsubst eieio--class-method-invocation-order (class)
326 "Return the invocation order of CLASS. 331 "Return the invocation order of CLASS.
327Abstract classes cannot be instantiated." 332Abstract classes cannot be instantiated."
328 `(or (class-option ,class :method-invocation-order) 333 (or (eieio--class-option class :method-invocation-order)
329 :breadth-first)) 334 :breadth-first))
330 335
331 336
332 337
@@ -380,7 +385,7 @@ It creates an autoload function for CNAME's constructor."
380 (gethash SC eieio-defclass-autoload-map))) 385 (gethash SC eieio-defclass-autoload-map)))
381 386
382 ;; Save parent in child. 387 ;; Save parent in child.
383 (push SC (eieio--class-parent newc))) 388 (push (eieio--class-v SC) (eieio--class-parent newc)))
384 389
385 ;; turn this into a usable self-pointing symbol 390 ;; turn this into a usable self-pointing symbol
386 (set cname cname) 391 (set cname cname)
@@ -476,9 +481,9 @@ See `defclass' for more information."
476 (cl-pushnew cname (eieio--class-children (eieio--class-v p))) 481 (cl-pushnew cname (eieio--class-children (eieio--class-v p)))
477 ;; Get custom groups, and store them into our local copy. 482 ;; Get custom groups, and store them into our local copy.
478 (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) 483 (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
479 (class-option p :custom-groups)) 484 (eieio--class-option (eieio--class-v p) :custom-groups))
480 ;; save parent in child 485 ;; save parent in child
481 (push p (eieio--class-parent newc))) 486 (push (eieio--class-v p) (eieio--class-parent newc)))
482 (error "Invalid parent class %S" p))) 487 (error "Invalid parent class %S" p)))
483 ;; Reverse the list of our parents so that they are prioritized in 488 ;; Reverse the list of our parents so that they are prioritized in
484 ;; the same order as specified in the code. 489 ;; the same order as specified in the code.
@@ -488,11 +493,10 @@ See `defclass' for more information."
488 (unless (eq cname 'eieio-default-superclass) 493 (unless (eq cname 'eieio-default-superclass)
489 ;; adopt the default parent here, but clear it later... 494 ;; adopt the default parent here, but clear it later...
490 (setq clearparent t) 495 (setq clearparent t)
491 ;; save new child in parent 496 ;; save new child in parent
492 (cl-pushnew cname (eieio--class-children 497 (cl-pushnew cname (eieio--class-children eieio-default-superclass))
493 (eieio--class-v 'eieio-default-superclass))) 498 ;; save parent in child
494 ;; save parent in child 499 (setf (eieio--class-parent newc) (list eieio-default-superclass))))
495 (setf (eieio--class-parent newc) '(eieio-default-superclass))))
496 500
497 ;; turn this into a usable self-pointing symbol; FIXME: Why? 501 ;; turn this into a usable self-pointing symbol; FIXME: Why?
498 (set cname cname) 502 (set cname cname)
@@ -510,7 +514,7 @@ See `defclass' for more information."
510 (same-class-p obj ',cname))))) 514 (same-class-p obj ',cname)))))
511 515
512 ;; Make sure the method invocation order is a valid value. 516 ;; Make sure the method invocation order is a valid value.
513 (let ((io (class-option-assoc options :method-invocation-order))) 517 (let ((io (eieio--class-option-assoc options :method-invocation-order)))
514 (when (and io (not (member io '(:depth-first :breadth-first :c3)))) 518 (when (and io (not (member io '(:depth-first :breadth-first :c3))))
515 (error "Method invocation order %s is not allowed" io) 519 (error "Method invocation order %s is not allowed" io)
516 )) 520 ))
@@ -568,23 +572,23 @@ See `defclass' for more information."
568 (let* ((slot1 (car slots)) 572 (let* ((slot1 (car slots))
569 (name (car slot1)) 573 (name (car slot1))
570 (slot (cdr slot1)) 574 (slot (cdr slot1))
571 (acces (plist-get slot ':accessor)) 575 (acces (plist-get slot :accessor))
572 (init (or (plist-get slot ':initform) 576 (init (or (plist-get slot :initform)
573 (if (member ':initform slot) nil 577 (if (member :initform slot) nil
574 eieio-unbound))) 578 eieio-unbound)))
575 (initarg (plist-get slot ':initarg)) 579 (initarg (plist-get slot :initarg))
576 (docstr (plist-get slot ':documentation)) 580 (docstr (plist-get slot :documentation))
577 (prot (plist-get slot ':protection)) 581 (prot (plist-get slot :protection))
578 (reader (plist-get slot ':reader)) 582 (reader (plist-get slot :reader))
579 (writer (plist-get slot ':writer)) 583 (writer (plist-get slot :writer))
580 (alloc (plist-get slot ':allocation)) 584 (alloc (plist-get slot :allocation))
581 (type (plist-get slot ':type)) 585 (type (plist-get slot :type))
582 (custom (plist-get slot ':custom)) 586 (custom (plist-get slot :custom))
583 (label (plist-get slot ':label)) 587 (label (plist-get slot :label))
584 (customg (plist-get slot ':group)) 588 (customg (plist-get slot :group))
585 (printer (plist-get slot ':printer)) 589 (printer (plist-get slot :printer))
586 590
587 (skip-nil (class-option-assoc options :allow-nil-initform)) 591 (skip-nil (eieio--class-option-assoc options :allow-nil-initform))
588 ) 592 )
589 593
590 (if eieio-error-unsupported-class-tags 594 (if eieio-error-unsupported-class-tags
@@ -613,18 +617,18 @@ See `defclass' for more information."
613 ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) 617 ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected))
614 ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) 618 ((or (eq prot 'private) (eq prot :private)) (setq prot 'private))
615 ((eq prot nil) nil) 619 ((eq prot nil) nil)
616 (t (signal 'invalid-slot-type (list ':protection prot)))) 620 (t (signal 'invalid-slot-type (list :protection prot))))
617 621
618 ;; Make sure the :allocation parameter has a valid value. 622 ;; Make sure the :allocation parameter has a valid value.
619 (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) 623 (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance)))
620 (signal 'invalid-slot-type (list ':allocation alloc))) 624 (signal 'invalid-slot-type (list :allocation alloc)))
621 625
622 ;; The default type specifier is supposed to be t, meaning anything. 626 ;; The default type specifier is supposed to be t, meaning anything.
623 (if (not type) (setq type t)) 627 (if (not type) (setq type t))
624 628
625 ;; Label is nil, or a string 629 ;; Label is nil, or a string
626 (if (not (or (null label) (stringp label))) 630 (if (not (or (null label) (stringp label)))
627 (signal 'invalid-slot-type (list ':label label))) 631 (signal 'invalid-slot-type (list :label label)))
628 632
629 ;; Is there an initarg, but allocation of class? 633 ;; Is there an initarg, but allocation of class?
630 (if (and initarg (eq alloc :class)) 634 (if (and initarg (eq alloc :class))
@@ -641,11 +645,11 @@ See `defclass' for more information."
641 ;; The customgroup better be a symbol, or list of symbols. 645 ;; The customgroup better be a symbol, or list of symbols.
642 (mapc (lambda (cg) 646 (mapc (lambda (cg)
643 (if (not (symbolp cg)) 647 (if (not (symbolp cg))
644 (signal 'invalid-slot-type (list ':group cg)))) 648 (signal 'invalid-slot-type (list :group cg))))
645 customg) 649 customg)
646 650
647 ;; First up, add this slot into our new class. 651 ;; First up, add this slot into our new class.
648 (eieio-add-new-slot newc name init docstr type custom label customg printer 652 (eieio--add-new-slot newc name init docstr type custom label customg printer
649 prot initarg alloc 'defaultoverride skip-nil) 653 prot initarg alloc 'defaultoverride skip-nil)
650 654
651 ;; We need to id the group, and store them in a group list attribute. 655 ;; We need to id the group, and store them in a group list attribute.
@@ -663,9 +667,13 @@ See `defclass' for more information."
663 "Retrieves the slot `%s' from an object of class `%s'" 667 "Retrieves the slot `%s' from an object of class `%s'"
664 name cname) 668 name cname)
665 (if (slot-boundp this ',name) 669 (if (slot-boundp this ',name)
666 (eieio-oref this ',name) 670 ;; Use oref-default for :class allocated slots, since
667 ;; Else - Some error? nil? 671 ;; these also accept the use of a class argument instead
668 nil))) 672 ;; of an object argument.
673 (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
674 this ',name)
675 ;; Else - Some error? nil?
676 nil)))
669 677
670 ;; FIXME: We should move more of eieio-defclass into the 678 ;; FIXME: We should move more of eieio-defclass into the
671 ;; defclass macro so we don't have to use `eval' and require 679 ;; defclass macro so we don't have to use `eval' and require
@@ -674,7 +682,12 @@ See `defclass' for more information."
674 ;; function, but the define-setter below affects the whole 682 ;; function, but the define-setter below affects the whole
675 ;; generic function! 683 ;; generic function!
676 (eval `(gv-define-setter ,acces (eieio--store eieio--object) 684 (eval `(gv-define-setter ,acces (eieio--store eieio--object)
677 (list 'eieio-oset eieio--object '',name 685 ;; Apparently, eieio-oset-default doesn't work like
686 ;; oref-default and only accept class arguments!
687 (list ',(if nil ;; (eq alloc :class)
688 'eieio-oset-default
689 'eieio-oset)
690 eieio--object '',name
678 eieio--store))))) 691 eieio--store)))))
679 692
680 ;; If a writer is defined, then create a generic method of that 693 ;; If a writer is defined, then create a generic method of that
@@ -737,9 +750,9 @@ See `defclass' for more information."
737 (setf (eieio--class-symbol-hashtable newc) oa)) 750 (setf (eieio--class-symbol-hashtable newc) oa))
738 751
739 ;; Create the constructor function 752 ;; Create the constructor function
740 (if (class-option-assoc options :abstract) 753 (if (eieio--class-option-assoc options :abstract)
741 ;; Abstract classes cannot be instantiated. Say so. 754 ;; Abstract classes cannot be instantiated. Say so.
742 (let ((abs (class-option-assoc options :abstract))) 755 (let ((abs (eieio--class-option-assoc options :abstract)))
743 (if (not (stringp abs)) 756 (if (not (stringp abs))
744 (setq abs (format "Class %s is abstract" cname))) 757 (setq abs (format "Class %s is abstract" cname)))
745 (fset cname 758 (fset cname
@@ -762,7 +775,7 @@ See `defclass' for more information."
762 ;; Set up a specialized doc string. 775 ;; Set up a specialized doc string.
763 ;; Use stored value since it is calculated in a non-trivial way 776 ;; Use stored value since it is calculated in a non-trivial way
764 (put cname 'variable-documentation 777 (put cname 'variable-documentation
765 (class-option-assoc options :documentation)) 778 (eieio--class-option-assoc options :documentation))
766 779
767 ;; Save the file location where this class is defined. 780 ;; Save the file location where this class is defined.
768 (let ((fname (if load-in-progress 781 (let ((fname (if load-in-progress
@@ -774,7 +787,7 @@ See `defclass' for more information."
774 (put cname 'class-location fname))) 787 (put cname 'class-location fname)))
775 788
776 ;; We have a list of custom groups. Store them into the options. 789 ;; We have a list of custom groups. Store them into the options.
777 (let ((g (class-option-assoc options :custom-groups))) 790 (let ((g (eieio--class-option-assoc options :custom-groups)))
778 (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) 791 (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups)
779 (if (memq :custom-groups options) 792 (if (memq :custom-groups options)
780 (setcar (cdr (memq :custom-groups options)) g) 793 (setcar (cdr (memq :custom-groups options)) g)
@@ -814,16 +827,16 @@ See `defclass' for more information."
814 "Whether the default value VAL should be evaluated for use." 827 "Whether the default value VAL should be evaluated for use."
815 (and (consp val) (symbolp (car val)) (fboundp (car val)))) 828 (and (consp val) (symbolp (car val)) (fboundp (car val))))
816 829
817(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) 830(defun eieio--perform-slot-validation-for-default (slot spec value skipnil)
818 "For SLOT, signal if SPEC does not match VALUE. 831 "For SLOT, signal if SPEC does not match VALUE.
819If SKIPNIL is non-nil, then if VALUE is nil return t instead." 832If SKIPNIL is non-nil, then if VALUE is nil return t instead."
820 (if (and (not (eieio-eval-default-p value)) 833 (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
821 (not eieio-skip-typecheck) 834 eieio-skip-typecheck
822 (not (and skipnil (null value))) 835 (and skipnil (null value))
823 (not (eieio-perform-slot-validation spec value))) 836 (eieio-perform-slot-validation spec value)))
824 (signal 'invalid-slot-type (list slot spec value)))) 837 (signal 'invalid-slot-type (list slot spec value))))
825 838
826(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc 839(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc
827 &optional defaultoverride skipnil) 840 &optional defaultoverride skipnil)
828 "Add into NEWC attribute A. 841 "Add into NEWC attribute A.
829If A already exists in NEWC, then do nothing. If it doesn't exist, 842If A already exists in NEWC, then do nothing. If it doesn't exist,
@@ -844,9 +857,9 @@ if default value is nil."
844 857
845 ;; To prevent override information w/out specification of storage, 858 ;; To prevent override information w/out specification of storage,
846 ;; we need to do this little hack. 859 ;; we need to do this little hack.
847 (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) 860 (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class))
848 861
849 (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) 862 (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance)))
850 ;; In this case, we modify the INSTANCE version of a given slot. 863 ;; In this case, we modify the INSTANCE version of a given slot.
851 864
852 (progn 865 (progn
@@ -854,16 +867,16 @@ if default value is nil."
854 ;; Only add this element if it is so-far unique 867 ;; Only add this element if it is so-far unique
855 (if (not (member a (eieio--class-public-a newc))) 868 (if (not (member a (eieio--class-public-a newc)))
856 (progn 869 (progn
857 (eieio-perform-slot-validation-for-default a type d skipnil) 870 (eieio--perform-slot-validation-for-default a type d skipnil)
858 (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) 871 (push a (eieio--class-public-a newc))
859 (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) 872 (push d (eieio--class-public-d newc))
860 (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) 873 (push doc (eieio--class-public-doc newc))
861 (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) 874 (push type (eieio--class-public-type newc))
862 (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) 875 (push cust (eieio--class-public-custom newc))
863 (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) 876 (push label (eieio--class-public-custom-label newc))
864 (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) 877 (push custg (eieio--class-public-custom-group newc))
865 (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) 878 (push print (eieio--class-public-printer newc))
866 (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) 879 (push prot (eieio--class-protection newc))
867 (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) 880 (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc)))
868 ) 881 )
869 ;; When defaultoverride is true, we are usually adding new local 882 ;; When defaultoverride is true, we are usually adding new local
@@ -889,7 +902,7 @@ if default value is nil."
889 type tp a))) 902 type tp a)))
890 ;; If we have a repeat, only update the initarg... 903 ;; If we have a repeat, only update the initarg...
891 (unless (eq d eieio-unbound) 904 (unless (eq d eieio-unbound)
892 (eieio-perform-slot-validation-for-default a tp d skipnil) 905 (eieio--perform-slot-validation-for-default a tp d skipnil)
893 (setcar dp d)) 906 (setcar dp d))
894 ;; If we have a new initarg, check for it. 907 ;; If we have a new initarg, check for it.
895 (when init 908 (when init
@@ -966,19 +979,19 @@ if default value is nil."
966 (let ((value (eieio-default-eval-maybe d))) 979 (let ((value (eieio-default-eval-maybe d)))
967 (if (not (member a (eieio--class-class-allocation-a newc))) 980 (if (not (member a (eieio--class-class-allocation-a newc)))
968 (progn 981 (progn
969 (eieio-perform-slot-validation-for-default a type value skipnil) 982 (eieio--perform-slot-validation-for-default a type value skipnil)
970 ;; Here we have found a :class version of a slot. This 983 ;; Here we have found a :class version of a slot. This
971 ;; requires a very different approach. 984 ;; requires a very different approach.
972 (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) 985 (push a (eieio--class-class-allocation-a newc))
973 (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) 986 (push doc (eieio--class-class-allocation-doc newc))
974 (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) 987 (push type (eieio--class-class-allocation-type newc))
975 (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) 988 (push cust (eieio--class-class-allocation-custom newc))
976 (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) 989 (push label (eieio--class-class-allocation-custom-label newc))
977 (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) 990 (push custg (eieio--class-class-allocation-custom-group newc))
978 (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) 991 (push prot (eieio--class-class-allocation-protection newc))
979 ;; Default value is stored in the 'values section, since new objects 992 ;; Default value is stored in the 'values section, since new objects
980 ;; can't initialize from this element. 993 ;; can't initialize from this element.
981 (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) 994 (push value (eieio--class-class-allocation-values newc)))
982 (when defaultoverride 995 (when defaultoverride
983 ;; There is a match, and we must override the old value. 996 ;; There is a match, and we must override the old value.
984 (let* ((ca (eieio--class-class-allocation-a newc)) 997 (let* ((ca (eieio--class-class-allocation-a newc))
@@ -1003,7 +1016,7 @@ if default value is nil."
1003 ;; is to change the default, so allow unbound in. 1016 ;; is to change the default, so allow unbound in.
1004 1017
1005 ;; If we have a repeat, only update the value... 1018 ;; If we have a repeat, only update the value...
1006 (eieio-perform-slot-validation-for-default a tp value skipnil) 1019 (eieio--perform-slot-validation-for-default a tp value skipnil)
1007 (setcar dp value)) 1020 (setcar dp value))
1008 1021
1009 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is 1022 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
@@ -1052,71 +1065,66 @@ if default value is nil."
1052 "Copy into NEWC the slots of PARENTS. 1065 "Copy into NEWC the slots of PARENTS.
1053Follow the rules of not overwriting early parents when applying to 1066Follow the rules of not overwriting early parents when applying to
1054the new child class." 1067the new child class."
1055 (let ((ps (eieio--class-parent newc)) 1068 (let ((sn (eieio--class-option-assoc (eieio--class-options newc)
1056 (sn (class-option-assoc (eieio--class-options newc) 1069 :allow-nil-initform)))
1057 ':allow-nil-initform))) 1070 (dolist (pcv (eieio--class-parent newc))
1058 (while ps
1059 ;; First, duplicate all the slots of the parent. 1071 ;; First, duplicate all the slots of the parent.
1060 (let ((pcv (eieio--class-v (car ps)))) 1072 (let ((pa (eieio--class-public-a pcv))
1061 (let ((pa (eieio--class-public-a pcv)) 1073 (pd (eieio--class-public-d pcv))
1062 (pd (eieio--class-public-d pcv)) 1074 (pdoc (eieio--class-public-doc pcv))
1063 (pdoc (eieio--class-public-doc pcv)) 1075 (ptype (eieio--class-public-type pcv))
1064 (ptype (eieio--class-public-type pcv)) 1076 (pcust (eieio--class-public-custom pcv))
1065 (pcust (eieio--class-public-custom pcv)) 1077 (plabel (eieio--class-public-custom-label pcv))
1066 (plabel (eieio--class-public-custom-label pcv)) 1078 (pcustg (eieio--class-public-custom-group pcv))
1067 (pcustg (eieio--class-public-custom-group pcv)) 1079 (printer (eieio--class-public-printer pcv))
1068 (printer (eieio--class-public-printer pcv)) 1080 (pprot (eieio--class-protection pcv))
1069 (pprot (eieio--class-protection pcv)) 1081 (pinit (eieio--class-initarg-tuples pcv))
1070 (pinit (eieio--class-initarg-tuples pcv)) 1082 (i 0))
1071 (i 0)) 1083 (while pa
1072 (while pa 1084 (eieio--add-new-slot newc
1073 (eieio-add-new-slot newc 1085 (car pa) (car pd) (car pdoc) (aref ptype i)
1074 (car pa) (car pd) (car pdoc) (aref ptype i) 1086 (car pcust) (car plabel) (car pcustg)
1075 (car pcust) (car plabel) (car pcustg) 1087 (car printer)
1076 (car printer) 1088 (car pprot) (car-safe (car pinit)) nil nil sn)
1077 (car pprot) (car-safe (car pinit)) nil nil sn) 1089 ;; Increment each value.
1078 ;; Increment each value. 1090 (setq pa (cdr pa)
1079 (setq pa (cdr pa) 1091 pd (cdr pd)
1080 pd (cdr pd) 1092 pdoc (cdr pdoc)
1081 pdoc (cdr pdoc) 1093 i (1+ i)
1082 i (1+ i) 1094 pcust (cdr pcust)
1083 pcust (cdr pcust) 1095 plabel (cdr plabel)
1084 plabel (cdr plabel) 1096 pcustg (cdr pcustg)
1085 pcustg (cdr pcustg) 1097 printer (cdr printer)
1086 printer (cdr printer) 1098 pprot (cdr pprot)
1087 pprot (cdr pprot) 1099 pinit (cdr pinit))
1088 pinit (cdr pinit)) 1100 )) ;; while/let
1089 )) ;; while/let 1101 ;; Now duplicate all the class alloc slots.
1090 ;; Now duplicate all the class alloc slots. 1102 (let ((pa (eieio--class-class-allocation-a pcv))
1091 (let ((pa (eieio--class-class-allocation-a pcv)) 1103 (pdoc (eieio--class-class-allocation-doc pcv))
1092 (pdoc (eieio--class-class-allocation-doc pcv)) 1104 (ptype (eieio--class-class-allocation-type pcv))
1093 (ptype (eieio--class-class-allocation-type pcv)) 1105 (pcust (eieio--class-class-allocation-custom pcv))
1094 (pcust (eieio--class-class-allocation-custom pcv)) 1106 (plabel (eieio--class-class-allocation-custom-label pcv))
1095 (plabel (eieio--class-class-allocation-custom-label pcv)) 1107 (pcustg (eieio--class-class-allocation-custom-group pcv))
1096 (pcustg (eieio--class-class-allocation-custom-group pcv)) 1108 (printer (eieio--class-class-allocation-printer pcv))
1097 (printer (eieio--class-class-allocation-printer pcv)) 1109 (pprot (eieio--class-class-allocation-protection pcv))
1098 (pprot (eieio--class-class-allocation-protection pcv)) 1110 (pval (eieio--class-class-allocation-values pcv))
1099 (pval (eieio--class-class-allocation-values pcv)) 1111 (i 0))
1100 (i 0)) 1112 (while pa
1101 (while pa 1113 (eieio--add-new-slot newc
1102 (eieio-add-new-slot newc 1114 (car pa) (aref pval i) (car pdoc) (aref ptype i)
1103 (car pa) (aref pval i) (car pdoc) (aref ptype i) 1115 (car pcust) (car plabel) (car pcustg)
1104 (car pcust) (car plabel) (car pcustg) 1116 (car printer)
1105 (car printer) 1117 (car pprot) nil :class sn)
1106 (car pprot) nil ':class sn) 1118 ;; Increment each value.
1107 ;; Increment each value. 1119 (setq pa (cdr pa)
1108 (setq pa (cdr pa) 1120 pdoc (cdr pdoc)
1109 pdoc (cdr pdoc) 1121 pcust (cdr pcust)
1110 pcust (cdr pcust) 1122 plabel (cdr plabel)
1111 plabel (cdr plabel) 1123 pcustg (cdr pcustg)
1112 pcustg (cdr pcustg) 1124 printer (cdr printer)
1113 printer (cdr printer) 1125 pprot (cdr pprot)
1114 pprot (cdr pprot) 1126 i (1+ i))
1115 i (1+ i)) 1127 )))))
1116 ))) ;; while/let
1117 ;; Loop over each parent class
1118 (setq ps (cdr ps)))
1119 ))
1120 1128
1121 1129
1122;;; CLOS methods and generics 1130;;; CLOS methods and generics
@@ -1333,14 +1341,17 @@ Argument FN is the function calling this verifier."
1333 (eieio--check-type (or eieio-object-p class-p) obj) 1341 (eieio--check-type (or eieio-object-p class-p) obj)
1334 (eieio--check-type symbolp slot) 1342 (eieio--check-type symbolp slot)
1335 (if (class-p obj) (eieio-class-un-autoload obj)) 1343 (if (class-p obj) (eieio-class-un-autoload obj))
1336 (let* ((class (if (class-p obj) obj (eieio--object-class-name obj))) 1344 (let* ((class (cond ((symbolp obj)
1337 (c (eieio--slot-name-index (eieio--class-v class) obj slot))) 1345 (error "eieio-oref called on a class!")
1346 (eieio--class-v obj))
1347 (t (eieio--object-class-object obj))))
1348 (c (eieio--slot-name-index class obj slot)))
1338 (if (not c) 1349 (if (not c)
1339 ;; It might be missing because it is a :class allocated slot. 1350 ;; It might be missing because it is a :class allocated slot.
1340 ;; Let's check that info out. 1351 ;; Let's check that info out.
1341 (if (setq c (eieio-class-slot-name-index class slot)) 1352 (if (setq c (eieio--class-slot-name-index class slot))
1342 ;; Oref that slot. 1353 ;; Oref that slot.
1343 (aref (eieio--class-class-allocation-values (eieio--class-v class)) c) 1354 (aref (eieio--class-class-allocation-values class) c)
1344 ;; The slot-missing method is a cool way of allowing an object author 1355 ;; The slot-missing method is a cool way of allowing an object author
1345 ;; to intercept missing slot definitions. Since it is also the LAST 1356 ;; to intercept missing slot definitions. Since it is also the LAST
1346 ;; thing called in this fn, its return value would be retrieved. 1357 ;; thing called in this fn, its return value would be retrieved.
@@ -1356,24 +1367,25 @@ Argument FN is the function calling this verifier."
1356Fills in OBJ's SLOT with its default value." 1367Fills in OBJ's SLOT with its default value."
1357 (eieio--check-type (or eieio-object-p class-p) obj) 1368 (eieio--check-type (or eieio-object-p class-p) obj)
1358 (eieio--check-type symbolp slot) 1369 (eieio--check-type symbolp slot)
1359 (let* ((cl (if (eieio-object-p obj) (eieio--object-class-name obj) obj)) 1370 (let* ((cl (cond ((symbolp obj) (eieio--class-v obj))
1360 (c (eieio--slot-name-index (eieio--class-v cl) obj slot))) 1371 (t (eieio--object-class-object obj))))
1372 (c (eieio--slot-name-index cl obj slot)))
1361 (if (not c) 1373 (if (not c)
1362 ;; It might be missing because it is a :class allocated slot. 1374 ;; It might be missing because it is a :class allocated slot.
1363 ;; Let's check that info out. 1375 ;; Let's check that info out.
1364 (if (setq c 1376 (if (setq c
1365 (eieio-class-slot-name-index cl slot)) 1377 (eieio--class-slot-name-index cl slot))
1366 ;; Oref that slot. 1378 ;; Oref that slot.
1367 (aref (eieio--class-class-allocation-values (eieio--class-v cl)) 1379 (aref (eieio--class-class-allocation-values cl)
1368 c) 1380 c)
1369 (slot-missing obj slot 'oref-default) 1381 (slot-missing obj slot 'oref-default)
1370 ;;(signal 'invalid-slot-name (list (class-name cl) slot)) 1382 ;;(signal 'invalid-slot-name (list (class-name cl) slot))
1371 ) 1383 )
1372 (eieio-barf-if-slot-unbound 1384 (eieio-barf-if-slot-unbound
1373 (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) 1385 (let ((val (nth (- c (eval-when-compile eieio--object-num-slots))
1374 (eieio--class-public-d (eieio--class-v cl))))) 1386 (eieio--class-public-d cl))))
1375 (eieio-default-eval-maybe val)) 1387 (eieio-default-eval-maybe val))
1376 obj cl 'oref-default)))) 1388 obj (eieio--class-symbol cl) 'oref-default))))
1377 1389
1378(defun eieio-default-eval-maybe (val) 1390(defun eieio-default-eval-maybe (val)
1379 "Check VAL, and return what `oref-default' would provide." 1391 "Check VAL, and return what `oref-default' would provide."
@@ -1398,7 +1410,7 @@ Fills in OBJ's SLOT with VALUE."
1398 ;; It might be missing because it is a :class allocated slot. 1410 ;; It might be missing because it is a :class allocated slot.
1399 ;; Let's check that info out. 1411 ;; Let's check that info out.
1400 (if (setq c 1412 (if (setq c
1401 (eieio-class-slot-name-index (eieio--class-symbol class) slot)) 1413 (eieio--class-slot-name-index class slot))
1402 ;; Oset that slot. 1414 ;; Oset that slot.
1403 (progn 1415 (progn
1404 (eieio-validate-class-slot-value (eieio--class-symbol class) 1416 (eieio-validate-class-slot-value (eieio--class-symbol class)
@@ -1422,7 +1434,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
1422 (if (not c) 1434 (if (not c)
1423 ;; It might be missing because it is a :class allocated slot. 1435 ;; It might be missing because it is a :class allocated slot.
1424 ;; Let's check that info out. 1436 ;; Let's check that info out.
1425 (if (setq c (eieio-class-slot-name-index class slot)) 1437 (if (setq c (eieio--class-slot-name-index (eieio--class-v class) slot))
1426 (progn 1438 (progn
1427 ;; Oref that slot. 1439 ;; Oref that slot.
1428 (eieio-validate-class-slot-value class c value slot) 1440 (eieio-validate-class-slot-value class c value slot)
@@ -1442,19 +1454,19 @@ Fills in the default value in CLASS' in SLOT with VALUE."
1442 1454
1443;;; EIEIO internal search functions 1455;;; EIEIO internal search functions
1444;; 1456;;
1445(defun eieio-slot-originating-class-p (start-class slot) 1457(defun eieio--slot-originating-class-p (start-class slot)
1446 "Return non-nil if START-CLASS is the first class to define SLOT. 1458 "Return non-nil if START-CLASS is the first class to define SLOT.
1447This is for testing if the class currently in scope is the class that defines SLOT 1459This is for testing if the class currently in scope is the class that defines SLOT
1448so that we can protect private slots." 1460so that we can protect private slots."
1449 (let ((par (eieio--class-parent start-class)) 1461 (let ((par (eieio--class-parent start-class))
1450 (ret t)) 1462 (ret t))
1451 (if (not par) 1463 (or (not par)
1452 t 1464 (progn
1453 (while (and par ret) 1465 (while (and par ret)
1454 (if (gethash slot (eieio--class-symbol-hashtable (eieio--class-v (car par)))) 1466 (if (gethash slot (eieio--class-symbol-hashtable (car par)))
1455 (setq ret nil)) 1467 (setq ret nil))
1456 (setq par (cdr par))) 1468 (setq par (cdr par)))
1457 ret))) 1469 ret))))
1458 1470
1459(defun eieio--slot-name-index (class obj slot) 1471(defun eieio--slot-name-index (class obj slot)
1460 "In CLASS for OBJ find the index of the named SLOT. 1472 "In CLASS for OBJ find the index of the named SLOT.
@@ -1475,25 +1487,31 @@ reverse-lookup that name, and recurse with the associated slot value."
1475 (eieio--scoped-class) 1487 (eieio--scoped-class)
1476 (or (child-of-class-p class (eieio--scoped-class)) 1488 (or (child-of-class-p class (eieio--scoped-class))
1477 (and (eieio-object-p obj) 1489 (and (eieio-object-p obj)
1478 (child-of-class-p class (eieio--object-class-object obj))))) 1490 ;; AFAICT, for all callers, if `obj' is not a class,
1491 ;; then its class is `class'.
1492 ;;(child-of-class-p class (eieio--object-class-object obj))
1493 (progn
1494 (cl-assert (eq class (eieio--object-class-object obj)))
1495 t))))
1479 (+ (eval-when-compile eieio--object-num-slots) fsi)) 1496 (+ (eval-when-compile eieio--object-num-slots) fsi))
1480 ((and (eq (cdr fsym) 'private) 1497 ((and (eq (cdr fsym) 'private)
1481 (or (and (eieio--scoped-class) 1498 (or (and (eieio--scoped-class)
1482 (eieio-slot-originating-class-p (eieio--scoped-class) slot)) 1499 (eieio--slot-originating-class-p
1500 (eieio--scoped-class) slot))
1483 eieio-initializing-object)) 1501 eieio-initializing-object))
1484 (+ (eval-when-compile eieio--object-num-slots) fsi)) 1502 (+ (eval-when-compile eieio--object-num-slots) fsi))
1485 (t nil)) 1503 (t nil))
1486 (let ((fn (eieio--initarg-to-attribute class slot))) 1504 (let ((fn (eieio--initarg-to-attribute class slot)))
1487 (if fn (eieio--slot-name-index class obj fn) nil))))) 1505 (if fn (eieio--slot-name-index class obj fn) nil)))))
1488 1506
1489(defun eieio-class-slot-name-index (class slot) 1507(defun eieio--class-slot-name-index (class slot)
1490 "In CLASS find the index of the named SLOT. 1508 "In CLASS find the index of the named SLOT.
1491The slot is a symbol which is installed in CLASS by the `defclass' 1509The slot is a symbol which is installed in CLASS by the `defclass'
1492call. If SLOT is the value created with :initarg instead, 1510call. If SLOT is the value created with :initarg instead,
1493reverse-lookup that name, and recurse with the associated slot value." 1511reverse-lookup that name, and recurse with the associated slot value."
1494 ;; This will happen less often, and with fewer slots. Do this the 1512 ;; This will happen less often, and with fewer slots. Do this the
1495 ;; storage cheap way. 1513 ;; storage cheap way.
1496 (let* ((a (eieio--class-class-allocation-a (eieio--class-v class))) 1514 (let* ((a (eieio--class-class-allocation-a class))
1497 (l1 (length a)) 1515 (l1 (length a))
1498 (af (memq slot a)) 1516 (af (memq slot a))
1499 (l2 (length af))) 1517 (l2 (length af)))
@@ -1528,18 +1546,10 @@ need be... May remove that later...)"
1528 (cdr tuple) 1546 (cdr tuple)
1529 nil))) 1547 nil)))
1530 1548
1531(defun eieio-attribute-to-initarg (class attribute)
1532 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
1533This is usually a symbol that starts with `:'."
1534 (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (eieio--class-v class)))))
1535 (if tuple
1536 (car tuple)
1537 nil)))
1538
1539;;; 1549;;;
1540;; Method Invocation order: C3 1550;; Method Invocation order: C3
1541(defun eieio-c3-candidate (class remaining-inputs) 1551(defun eieio--c3-candidate (class remaining-inputs)
1542 "Return CLASS if it can go in the result now, otherwise nil" 1552 "Return CLASS if it can go in the result now, otherwise nil."
1543 ;; Ensure CLASS is not in any position but the first in any of the 1553 ;; Ensure CLASS is not in any position but the first in any of the
1544 ;; element lists of REMAINING-INPUTS. 1554 ;; element lists of REMAINING-INPUTS.
1545 (and (not (let ((found nil)) 1555 (and (not (let ((found nil))
@@ -1549,7 +1559,7 @@ This is usually a symbol that starts with `:'."
1549 found)) 1559 found))
1550 class)) 1560 class))
1551 1561
1552(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) 1562(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
1553 "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. 1563 "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
1554If a consistent order does not exist, signal an error." 1564If a consistent order does not exist, signal an error."
1555 (if (let ((tail remaining-inputs) 1565 (if (let ((tail remaining-inputs)
@@ -1568,41 +1578,38 @@ If a consistent order does not exist, signal an error."
1568 (next (progn 1578 (next (progn
1569 (while (and tail (not found)) 1579 (while (and tail (not found))
1570 (setq found (and (car tail) 1580 (setq found (and (car tail)
1571 (eieio-c3-candidate (caar tail) 1581 (eieio--c3-candidate (caar tail)
1572 remaining-inputs)) 1582 remaining-inputs))
1573 tail (cdr tail))) 1583 tail (cdr tail)))
1574 found))) 1584 found)))
1575 (if next 1585 (if next
1576 ;; The graph is consistent so far, add NEXT to result and 1586 ;; The graph is consistent so far, add NEXT to result and
1577 ;; merge input lists, dropping NEXT from their heads where 1587 ;; merge input lists, dropping NEXT from their heads where
1578 ;; applicable. 1588 ;; applicable.
1579 (eieio-c3-merge-lists 1589 (eieio--c3-merge-lists
1580 (cons next reversed-partial-result) 1590 (cons next reversed-partial-result)
1581 (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) 1591 (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
1582 remaining-inputs)) 1592 remaining-inputs))
1583 ;; The graph is inconsistent, give up 1593 ;; The graph is inconsistent, give up
1584 (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) 1594 (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
1585 1595
1586(defun eieio-class-precedence-c3 (class) 1596(defun eieio--class-precedence-c3 (class)
1587 "Return all parents of CLASS in c3 order." 1597 "Return all parents of CLASS in c3 order."
1588 (let ((parents (eieio-class-parents-fast class))) 1598 (let ((parents (eieio--class-parent (eieio--class-v class))))
1589 (eieio-c3-merge-lists 1599 (eieio--c3-merge-lists
1590 (list class) 1600 (list class)
1591 (append 1601 (append
1592 (or 1602 (or
1593 (mapcar 1603 (mapcar #'eieio--class-precedence-c3 parents)
1594 (lambda (x) 1604 `((,eieio-default-superclass)))
1595 (eieio-class-precedence-c3 x))
1596 parents)
1597 '((eieio-default-superclass)))
1598 (list parents)))) 1605 (list parents))))
1599 ) 1606 )
1600;;; 1607;;;
1601;; Method Invocation Order: Depth First 1608;; Method Invocation Order: Depth First
1602 1609
1603(defun eieio-class-precedence-dfs (class) 1610(defun eieio--class-precedence-dfs (class)
1604 "Return all parents of CLASS in depth-first order." 1611 "Return all parents of CLASS in depth-first order."
1605 (let* ((parents (eieio-class-parents-fast class)) 1612 (let* ((parents (eieio--class-parent class))
1606 (classes (copy-sequence 1613 (classes (copy-sequence
1607 (apply #'append 1614 (apply #'append
1608 (list class) 1615 (list class)
@@ -1610,9 +1617,9 @@ If a consistent order does not exist, signal an error."
1610 (mapcar 1617 (mapcar
1611 (lambda (parent) 1618 (lambda (parent)
1612 (cons parent 1619 (cons parent
1613 (eieio-class-precedence-dfs parent))) 1620 (eieio--class-precedence-dfs parent)))
1614 parents) 1621 parents)
1615 '((eieio-default-superclass)))))) 1622 `((,eieio-default-superclass))))))
1616 (tail classes)) 1623 (tail classes))
1617 ;; Remove duplicates. 1624 ;; Remove duplicates.
1618 (while tail 1625 (while tail
@@ -1622,40 +1629,40 @@ If a consistent order does not exist, signal an error."
1622 1629
1623;;; 1630;;;
1624;; Method Invocation Order: Breadth First 1631;; Method Invocation Order: Breadth First
1625(defun eieio-class-precedence-bfs (class) 1632(defun eieio--class-precedence-bfs (class)
1626 "Return all parents of CLASS in breadth-first order." 1633 "Return all parents of CLASS in breadth-first order."
1627 (let ((result) 1634 (let* ((result)
1628 (queue (or (eieio-class-parents-fast class) 1635 (queue (or (eieio--class-parent class)
1629 '(eieio-default-superclass)))) 1636 `(,eieio-default-superclass))))
1630 (while queue 1637 (while queue
1631 (let ((head (pop queue))) 1638 (let ((head (pop queue)))
1632 (unless (member head result) 1639 (unless (member head result)
1633 (push head result) 1640 (push head result)
1634 (unless (eq head 'eieio-default-superclass) 1641 (unless (eq head eieio-default-superclass)
1635 (setq queue (append queue (or (eieio-class-parents-fast head) 1642 (setq queue (append queue (or (eieio--class-parent head)
1636 '(eieio-default-superclass)))))))) 1643 `(,eieio-default-superclass))))))))
1637 (cons class (nreverse result))) 1644 (cons class (nreverse result)))
1638 ) 1645 )
1639 1646
1640;;; 1647;;;
1641;; Method Invocation Order 1648;; Method Invocation Order
1642 1649
1643(defun eieio-class-precedence-list (class) 1650(defun eieio--class-precedence-list (class)
1644 "Return (transitively closed) list of parents of CLASS. 1651 "Return (transitively closed) list of parents of CLASS.
1645The order, in which the parents are returned depends on the 1652The order, in which the parents are returned depends on the
1646method invocation orders of the involved classes." 1653method invocation orders of the involved classes."
1647 (if (or (null class) (eq class 'eieio-default-superclass)) 1654 (if (or (null class) (eq class eieio-default-superclass))
1648 nil 1655 nil
1649 (cl-case (class-method-invocation-order class) 1656 (cl-case (eieio--class-method-invocation-order class)
1650 (:depth-first 1657 (:depth-first
1651 (eieio-class-precedence-dfs class)) 1658 (eieio--class-precedence-dfs class))
1652 (:breadth-first 1659 (:breadth-first
1653 (eieio-class-precedence-bfs class)) 1660 (eieio--class-precedence-bfs class))
1654 (:c3 1661 (:c3
1655 (eieio-class-precedence-c3 class)))) 1662 (eieio--class-precedence-c3 class))))
1656 ) 1663 )
1657(define-obsolete-function-alias 1664(define-obsolete-function-alias
1658 'class-precedence-list 'eieio-class-precedence-list "24.4") 1665 'class-precedence-list 'eieio--class-precedence-list "24.4")
1659 1666
1660 1667
1661;;; CLOS generics internal function handling 1668;;; CLOS generics internal function handling
@@ -1688,9 +1695,8 @@ This should only be called from a generic function."
1688 ;; function loaded anyway. 1695 ;; function loaded anyway.
1689 (if (and (symbolp firstarg) 1696 (if (and (symbolp firstarg)
1690 (fboundp firstarg) 1697 (fboundp firstarg)
1691 (listp (symbol-function firstarg)) 1698 (autoloadp (symbol-function firstarg)))
1692 (eq 'autoload (car (symbol-function firstarg)))) 1699 (autoload-do-load (symbol-function firstarg)))
1693 (load (nth 1 (symbol-function firstarg))))
1694 ;; Determine the class to use. 1700 ;; Determine the class to use.
1695 (cond ((eieio-object-p firstarg) 1701 (cond ((eieio-object-p firstarg)
1696 (setq mclass (eieio--object-class-name firstarg))) 1702 (setq mclass (eieio--object-class-name firstarg)))
@@ -1700,7 +1706,7 @@ This should only be called from a generic function."
1700 ;; Make sure the class is a valid class 1706 ;; Make sure the class is a valid class
1701 ;; mclass can be nil (meaning a generic for should be used. 1707 ;; mclass can be nil (meaning a generic for should be used.
1702 ;; mclass cannot have a value that is not a class, however. 1708 ;; mclass cannot have a value that is not a class, however.
1703 (when (and (not (null mclass)) (not (class-p mclass))) 1709 (unless (or (null mclass) (class-p mclass))
1704 (error "Cannot dispatch method %S on class %S" 1710 (error "Cannot dispatch method %S on class %S"
1705 method mclass) 1711 method mclass)
1706 ) 1712 )
@@ -1776,7 +1782,7 @@ This should only be called from a generic function."
1776 (let ((rval nil) (lastval nil) (found nil)) 1782 (let ((rval nil) (lastval nil) (found nil))
1777 (while lambdas 1783 (while lambdas
1778 (if (car lambdas) 1784 (if (car lambdas)
1779 (eieio--with-scoped-class (eieio--class-v (cdr (car lambdas))) 1785 (eieio--with-scoped-class (cdr (car lambdas))
1780 (let* ((eieio-generic-call-key (car keys)) 1786 (let* ((eieio-generic-call-key (car keys))
1781 (has-return-val 1787 (has-return-val
1782 (or (= eieio-generic-call-key eieio--method-primary) 1788 (or (= eieio-generic-call-key eieio--method-primary)
@@ -1844,7 +1850,7 @@ for this common case to improve performance."
1844 1850
1845 ;; Now loop through all occurrences forms which we must execute 1851 ;; Now loop through all occurrences forms which we must execute
1846 ;; (which are happily sorted now) and execute them all! 1852 ;; (which are happily sorted now) and execute them all!
1847 (eieio--with-scoped-class (eieio--class-v (cdr lambdas)) 1853 (eieio--with-scoped-class (cdr lambdas)
1848 (let* ((rval nil) (lastval nil) 1854 (let* ((rval nil) (lastval nil)
1849 (eieio-generic-call-key eieio--method-primary) 1855 (eieio-generic-call-key eieio--method-primary)
1850 ;; Use the cdr, as the first element is the fcn 1856 ;; Use the cdr, as the first element is the fcn
@@ -1884,7 +1890,7 @@ If CLASS is nil, then an empty list of methods should be returned."
1884 ;; Collect lambda expressions stored for the class and its parent 1890 ;; Collect lambda expressions stored for the class and its parent
1885 ;; classes. 1891 ;; classes.
1886 (let (lambdas) 1892 (let (lambdas)
1887 (dolist (ancestor (eieio-class-precedence-list class)) 1893 (dolist (ancestor (eieio--class-precedence-list (eieio--class-v class)))
1888 ;; Lookup the form to use for the PRIMARY object for the next level 1894 ;; Lookup the form to use for the PRIMARY object for the next level
1889 (let ((tmpl (eieio-generic-form method key ancestor))) 1895 (let ((tmpl (eieio-generic-form method key ancestor)))
1890 (when (and tmpl 1896 (when (and tmpl
@@ -1961,7 +1967,7 @@ CLASS is the class this method is associated with."
1961 ;; said symbol in the correct hashtable, otherwise use the 1967 ;; said symbol in the correct hashtable, otherwise use the
1962 ;; other array to keep this stuff. 1968 ;; other array to keep this stuff.
1963 (if (< key eieio--method-num-lists) 1969 (if (< key eieio--method-num-lists)
1964 (puthash class (list method) (aref emto key))) 1970 (puthash (eieio--class-v class) (list method) (aref emto key)))
1965 ;; Save the defmethod file location in a symbol property. 1971 ;; Save the defmethod file location in a symbol property.
1966 (let ((fname (if load-in-progress 1972 (let ((fname (if load-in-progress
1967 load-file-name 1973 load-file-name
@@ -1986,7 +1992,7 @@ This is different from function `class-parent' as class parent returns
1986nil for superclasses. This function performs no type checking!" 1992nil for superclasses. This function performs no type checking!"
1987 ;; No type-checking because all calls are made from functions which 1993 ;; No type-checking because all calls are made from functions which
1988 ;; are safe and do checking for us. 1994 ;; are safe and do checking for us.
1989 (or (eieio-class-parents-fast class) 1995 (or (eieio--class-parent (eieio--class-v class))
1990 (if (eq class 'eieio-default-superclass) 1996 (if (eq class 'eieio-default-superclass)
1991 nil 1997 nil
1992 '(eieio-default-superclass)))) 1998 '(eieio-default-superclass))))
@@ -1999,7 +2005,7 @@ nil for superclasses. This function performs no type checking!"
1999 ;; we replace the nil from above. 2005 ;; we replace the nil from above.
2000 (catch 'done 2006 (catch 'done
2001 (dolist (ancestor 2007 (dolist (ancestor
2002 (cl-rest (eieio-class-precedence-list class))) 2008 (cl-rest (eieio--class-precedence-list class)))
2003 (let ((ov (gethash ancestor eieiomt--optimizing-hashtable))) 2009 (let ((ov (gethash ancestor eieiomt--optimizing-hashtable)))
2004 (when (car ov) 2010 (when (car ov)
2005 (setcdr s ancestor) ;; store ov as our next symbol 2011 (setcdr s ancestor) ;; store ov as our next symbol
@@ -2011,9 +2017,10 @@ If CLASS is not a class then use `generic' instead. If class has
2011no form, but has a parent class, then trace to that parent class. 2017no form, but has a parent class, then trace to that parent class.
2012The first time a form is requested from a symbol, an optimized path 2018The first time a form is requested from a symbol, an optimized path
2013is memorized for faster future use." 2019is memorized for faster future use."
2020 (if (symbolp class) (setq class (eieio--class-v class)))
2014 (let ((emto (aref (get method 'eieio-method-hashtable) 2021 (let ((emto (aref (get method 'eieio-method-hashtable)
2015 (if class key (eieio-specialized-key-to-generic-key key))))) 2022 (if class key (eieio-specialized-key-to-generic-key key)))))
2016 (if (class-p class) 2023 (if (eieio--class-p class)
2017 ;; 1) find our symbol 2024 ;; 1) find our symbol
2018 (let ((cs (gethash class emto))) 2025 (let ((cs (gethash class emto)))
2019 (unless cs 2026 (unless cs
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 15a11ddb20f..fe88c864d52 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -208,8 +208,8 @@ Optional argument IGNORE is an extraneous parameter."
208 chil))) 208 chil)))
209 ;; Display information about the group being shown 209 ;; Display information about the group being shown
210 (when master-group 210 (when master-group
211 (let ((groups (class-option (eieio--object-class-name obj) 211 (let ((groups (eieio--class-option (eieio--object-class-object obj)
212 :custom-groups))) 212 :custom-groups)))
213 (widget-insert "Groups:") 213 (widget-insert "Groups:")
214 (while groups 214 (while groups
215 (widget-insert " ") 215 (widget-insert " ")
@@ -261,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter."
261 (car flabel) 261 (car flabel)
262 (let ((s (symbol-name 262 (let ((s (symbol-name
263 (or 263 (or
264 (class-slot-initarg 264 (eieio--class-slot-initarg
265 (eieio--object-class-name obj) 265 (eieio--object-class-object obj)
266 (car slots)) 266 (car slots))
267 (car slots))))) 267 (car slots)))))
268 (capitalize 268 (capitalize
@@ -452,7 +452,7 @@ Must return the created widget."
452 (vector (concat "Group " (symbol-name group)) 452 (vector (concat "Group " (symbol-name group))
453 (list 'customize-object obj (list 'quote group)) 453 (list 'customize-object obj (list 'quote group))
454 t)) 454 t))
455 (class-option (eieio--object-class-name obj) :custom-groups))) 455 (eieio--class-option (eieio--object-class-object obj) :custom-groups)))
456 456
457(defvar eieio-read-custom-group-history nil 457(defvar eieio-read-custom-group-history nil
458 "History for the custom group reader.") 458 "History for the custom group reader.")
@@ -460,7 +460,8 @@ Must return the created widget."
460(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) 460(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
461 "Do a completing read on the name of a customization group in OBJ. 461 "Do a completing read on the name of a customization group in OBJ.
462Return the symbol for the group, or nil" 462Return the symbol for the group, or nil"
463 (let ((g (class-option (eieio--object-class-name obj) :custom-groups))) 463 (let ((g (eieio--class-option (eieio--object-class-object obj)
464 :custom-groups)))
464 (if (= (length g) 1) 465 (if (= (length g) 1)
465 (car g) 466 (car g)
466 ;; Make the association list 467 ;; Make the association list
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index d18501b414c..69e72573deb 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
96 ) 96 )
97 (while publa 97 (while publa
98 (if (slot-boundp obj (car publa)) 98 (if (slot-boundp obj (car publa))
99 (let* ((i (class-slot-initarg cl (car publa))) 99 (let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
100 (car publa)))
100 (v (eieio-oref obj (car publa)))) 101 (v (eieio-oref obj (car publa))))
101 (data-debug-insert-thing 102 (data-debug-insert-thing
102 v prefix (concat 103 v prefix (concat
@@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
104 (symbol-name (car publa))) 105 (symbol-name (car publa)))
105 " "))) 106 " ")))
106 ;; Unbound case 107 ;; Unbound case
107 (let ((i (class-slot-initarg cl (car publa)))) 108 (let ((i (eieio--class-slot-initarg (eieio--class-v cl)
109 (car publa))))
108 (data-debug-insert-custom 110 (data-debug-insert-custom
109 "#unbound" prefix 111 "#unbound" prefix
110 (concat (if i (symbol-name i) 112 (concat (if i (symbol-name i)
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 1987385de0b..be3c2b0cc94 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object.
81 ;; Header line 81 ;; Header line
82 (prin1 class) 82 (prin1 class)
83 (insert " is a" 83 (insert " is a"
84 (if (class-option class :abstract) 84 (if (eieio--class-option (eieio--class-v class) :abstract)
85 "n abstract" 85 "n abstract"
86 "") 86 "")
87 " class") 87 " class")
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index e80791f9f75..878667106c8 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -1,7 +1,7 @@
1;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- 1;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*-
2;;; or maybe Eric's Implementation of Emacs Interpreted Objects 2;;; or maybe Eric's Implementation of Emacs Interpreted Objects
3 3
4;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. 4;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
5 5
6;; Author: Eric M. Ludlam <zappo@gnu.org> 6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 1.4 7;; Version: 1.4
@@ -319,8 +319,9 @@ If EXTRA, include that in the string returned to represent the symbol."
319 "Return parent classes to CLASS. (overload of variable). 319 "Return parent classes to CLASS. (overload of variable).
320 320
321The CLOS function `class-direct-superclasses' is aliased to this function." 321The CLOS function `class-direct-superclasses' is aliased to this function."
322 (eieio--check-type class-p class) 322 (let ((c (eieio-class-object class)))
323 (eieio-class-parents-fast class)) 323 (eieio--class-parent c)))
324
324(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") 325(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
325 326
326(defun eieio-class-children (class) 327(defun eieio-class-children (class)
@@ -366,10 +367,8 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
366 (setq class (eieio--class-object class)) 367 (setq class (eieio--class-object class))
367 (eieio--check-type eieio--class-p class) 368 (eieio--check-type eieio--class-p class)
368 (while (and child (not (eq child class))) 369 (while (and child (not (eq child class)))
369 ;; FIXME: eieio--class-parent should return class-objects rather than
370 ;; class-names!
371 (setq p (append p (eieio--class-parent child)) 370 (setq p (append p (eieio--class-parent child))
372 child (eieio--class-v (pop p)))) 371 child (pop p)))
373 (if child t)))) 372 (if child t))))
374 373
375(defun object-slots (obj) 374(defun object-slots (obj)
@@ -377,9 +376,9 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
377 (eieio--check-type eieio-object-p obj) 376 (eieio--check-type eieio-object-p obj)
378 (eieio--class-public-a (eieio--object-class-object obj))) 377 (eieio--class-public-a (eieio--object-class-object obj)))
379 378
380(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." 379(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
381 (eieio--check-type class-p class) 380 (eieio--check-type eieio--class-p class)
382 (let ((ia (eieio--class-initarg-tuples (eieio--class-v class))) 381 (let ((ia (eieio--class-initarg-tuples class))
383 (f nil)) 382 (f nil))
384 (while (and ia (not f)) 383 (while (and ia (not f))
385 (if (eq (cdr (car ia)) slot) 384 (if (eq (cdr (car ia)) slot)
@@ -426,11 +425,9 @@ OBJECT can be an instance or a class."
426 425
427(defun slot-exists-p (object-or-class slot) 426(defun slot-exists-p (object-or-class slot)
428 "Return non-nil if OBJECT-OR-CLASS has SLOT." 427 "Return non-nil if OBJECT-OR-CLASS has SLOT."
429 (let ((cv (eieio--class-v (cond ((eieio-object-p object-or-class) 428 (let ((cv (cond ((eieio-object-p object-or-class)
430 (eieio-object-class object-or-class)) 429 (eieio--object-class-object object-or-class))
431 ((class-p object-or-class) 430 (t (eieio-class-object object-or-class)))))
432 object-or-class))
433 )))
434 (or (memq slot (eieio--class-public-a cv)) 431 (or (memq slot (eieio--class-public-a cv))
435 (memq slot (eieio--class-class-allocation-a cv))) 432 (memq slot (eieio--class-class-allocation-a cv)))
436 )) 433 ))
@@ -555,7 +552,7 @@ Use `next-method-p' to find out if there is a next method to call."
555 (eieio-generic-call-arglst newargs) 552 (eieio-generic-call-arglst newargs)
556 (fcn (car next)) 553 (fcn (car next))
557 ) 554 )
558 (eieio--with-scoped-class (eieio--class-v (cdr next)) 555 (eieio--with-scoped-class (cdr next)
559 (apply fcn newargs)) )))) 556 (apply fcn newargs)) ))))
560 557
561;;; Here are some CLOS items that need the CL package 558;;; Here are some CLOS items that need the CL package
@@ -580,6 +577,8 @@ Its slots are automatically adopted by classes with no specified parents.
580This class is not stored in the `parent' slot of a class vector." 577This class is not stored in the `parent' slot of a class vector."
581 :abstract t) 578 :abstract t)
582 579
580(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass))
581
583(defalias 'standard-class 'eieio-default-superclass) 582(defalias 'standard-class 'eieio-default-superclass)
584 583
585(defgeneric eieio-constructor (class &rest slots) 584(defgeneric eieio-constructor (class &rest slots)
@@ -797,7 +796,7 @@ this object."
797 (eieio-print-depth (1+ eieio-print-depth))) 796 (eieio-print-depth (1+ eieio-print-depth)))
798 (while publa 797 (while publa
799 (when (slot-boundp this (car publa)) 798 (when (slot-boundp this (car publa))
800 (let ((i (class-slot-initarg cl (car publa))) 799 (let ((i (eieio--class-slot-initarg cv (car publa)))
801 (v (eieio-oref this (car publa))) 800 (v (eieio-oref this (car publa)))
802 ) 801 )
803 (unless (or (not i) (equal v (car publd))) 802 (unless (or (not i) (equal v (car publd)))
@@ -874,11 +873,13 @@ of `eq'."
874Used as advice around `edebug-prin1-to-string', held in the 873Used as advice around `edebug-prin1-to-string', held in the
875variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to 874variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
876`prin1-to-string' when appropriate." 875`prin1-to-string' when appropriate."
877 (cond ((class-p object) (eieio-class-name object)) 876 (cond ((eieio--class-p object) (eieio-class-name object))
878 ((eieio-object-p object) (object-print object)) 877 ((eieio-object-p object) (object-print object))
879 ((and (listp object) (or (class-p (car object)) 878 ((and (listp object) (or (eieio--class-p (car object))
880 (eieio-object-p (car object)))) 879 (eieio-object-p (car object))))
881 (concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ") 880 (concat "(" (mapconcat
881 (lambda (x) (eieio-edebug-prin1-to-string print-function x))
882 object " ")
882 ")")) 883 ")"))
883 (t (funcall print-function object noescape)))) 884 (t (funcall print-function object noescape))))
884 885
@@ -888,7 +889,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
888 889
889;;; Start of automatically extracted autoloads. 890;;; Start of automatically extracted autoloads.
890 891
891;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2b4c57cf907e879e8bbc88d8f0e2de4c") 892;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "a3f314e2a27e52444df4597c6ae51458")
892;;; Generated autoloads from eieio-custom.el 893;;; Generated autoloads from eieio-custom.el
893 894
894(autoload 'customize-object "eieio-custom" "\ 895(autoload 'customize-object "eieio-custom" "\
diff --git a/test/ChangeLog b/test/ChangeLog
index 53e2c49c9d7..8e3b83efbb0 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,16 @@
12015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/eieio-tests.el (eieio-test-04-static-method)
4 (eieio-test-05-static-method-2): Use oref-default to access
5 class slots.
6 (eieio-test-23-inheritance-check): Don't assume that
7 eieio-class-parents returns class names, or that a class can only have
8 a single name.
9
10 * automated/eieio-test-persist.el (eieio--attribute-to-initarg):
11 Move from eieio-core.el. Rename from eieio-attribute-to-initarg.
12 Change arg to be a class object. Update all callers.
13
12014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> 142014-12-29 Stefan Monnier <monnier@iro.umontreal.ca>
2 15
3 * automated/eieio-test-methodinvoke.el (eieio-test-method-store): 16 * automated/eieio-test-methodinvoke.el (eieio-test-method-store):
diff --git a/test/automated/eieio-test-persist.el b/test/automated/eieio-test-persist.el
index 00de3cf0d7c..5ea7cf25740 100644
--- a/test/automated/eieio-test-persist.el
+++ b/test/automated/eieio-test-persist.el
@@ -32,6 +32,14 @@
32(require 'eieio-base) 32(require 'eieio-base)
33(require 'ert) 33(require 'ert)
34 34
35(defun eieio--attribute-to-initarg (class attribute)
36 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
37This is usually a symbol that starts with `:'."
38 (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class))))
39 (if tuple
40 (car tuple)
41 nil)))
42
35(defun persist-test-save-and-compare (original) 43(defun persist-test-save-and-compare (original)
36 "Compare the object ORIGINAL against the one read fromdisk." 44 "Compare the object ORIGINAL against the one read fromdisk."
37 45
@@ -53,7 +61,8 @@
53 (let* ((oneslot (car slot-names)) 61 (let* ((oneslot (car slot-names))
54 (origvalue (eieio-oref original oneslot)) 62 (origvalue (eieio-oref original oneslot))
55 (fromdiskvalue (eieio-oref fromdisk oneslot)) 63 (fromdiskvalue (eieio-oref fromdisk oneslot))
56 (initarg-p (eieio-attribute-to-initarg class oneslot)) 64 (initarg-p (eieio--attribute-to-initarg
65 (eieio--class-v class) oneslot))
57 ) 66 )
58 67
59 (if initarg-p 68 (if initarg-p
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el
index 91ddfc4fcf3..f3088bacf32 100644
--- a/test/automated/eieio-tests.el
+++ b/test/automated/eieio-tests.el
@@ -1,6 +1,6 @@
1;;; eieio-tests.el -- eieio tests routines 1;;; eieio-tests.el -- eieio tests routines
2 2
3;; Copyright (C) 1999-2003, 2005-2010, 2012-2014 Free Software Foundation, Inc. 3;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software Foundation, Inc.
4 4
5;; Author: Eric M. Ludlam <zappo@gnu.org> 5;; Author: Eric M. Ludlam <zappo@gnu.org>
6 6
@@ -199,9 +199,9 @@ Argument C is the class bound to this static method."
199(ert-deftest eieio-test-04-static-method () 199(ert-deftest eieio-test-04-static-method ()
200 ;; Call static method on a class and see if it worked 200 ;; Call static method on a class and see if it worked
201 (static-method-class-method static-method-class 'class) 201 (static-method-class-method static-method-class 'class)
202 (should (eq (oref static-method-class some-slot) 'class)) 202 (should (eq (oref-default static-method-class some-slot) 'class))
203 (static-method-class-method (static-method-class) 'object) 203 (static-method-class-method (static-method-class) 'object)
204 (should (eq (oref static-method-class some-slot) 'object))) 204 (should (eq (oref-default static-method-class some-slot) 'object)))
205 205
206(ert-deftest eieio-test-05-static-method-2 () 206(ert-deftest eieio-test-05-static-method-2 ()
207 (defclass static-method-class-2 (static-method-class) 207 (defclass static-method-class-2 (static-method-class)
@@ -215,9 +215,9 @@ Argument C is the class bound to this static method."
215 (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) 215 (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
216 216
217 (static-method-class-method static-method-class-2 'class) 217 (static-method-class-method static-method-class-2 'class)
218 (should (eq (oref static-method-class-2 some-slot) 'moose-class)) 218 (should (eq (oref-default static-method-class-2 some-slot) 'moose-class))
219 (static-method-class-method (static-method-class-2) 'object) 219 (static-method-class-method (static-method-class-2) 'object)
220 (should (eq (oref static-method-class-2 some-slot) 'moose-object))) 220 (should (eq (oref-default static-method-class-2 some-slot) 'moose-object)))
221 221
222 222
223;;; Perform method testing 223;;; Perform method testing
@@ -536,7 +536,9 @@ METHOD is the method that was attempting to be called."
536 (should (object-of-class-p eitest-ab class-b)) 536 (should (object-of-class-p eitest-ab class-b))
537 (should (object-of-class-p eitest-ab class-ab)) 537 (should (object-of-class-p eitest-ab class-ab))
538 (should (eq (eieio-class-parents class-a) nil)) 538 (should (eq (eieio-class-parents class-a) nil))
539 (should (equal (eieio-class-parents class-ab) '(class-a class-b))) 539 ;; FIXME: eieio-class-parents now returns class objects!
540 (should (equal (mapcar #'eieio-class-object (eieio-class-parents class-ab))
541 (mapcar #'eieio-class-object '(class-a class-b))))
540 (should (same-class-p eitest-a class-a)) 542 (should (same-class-p eitest-a class-a))
541 (should (class-a-p eitest-a)) 543 (should (class-a-p eitest-a))
542 (should (not (class-a-p eitest-ab))) 544 (should (not (class-a-p eitest-ab)))