aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2013-02-18 21:57:04 -0500
committerStefan Monnier2013-02-18 21:57:04 -0500
commit8ca4f1e02e22f74dc269b01bc4a32e01dd226dae (patch)
tree0ed0df06d6430b812797c5ed3f4ff15b425a8dae
parent6a0fda530d1d76374f72f8dfb2a0a3d50023e64d (diff)
downloademacs-8ca4f1e02e22f74dc269b01bc4a32e01dd226dae.tar.gz
emacs-8ca4f1e02e22f74dc269b01bc4a32e01dd226dae.zip
Cleanup some of EIEIO's namespace.
* lisp/emacs-lisp/eieio.el (eieio--define-field-accessors): New macro. Use it to define all the class-* and object-* field accessors (renamed to eieio--class-* and eieio--object-*). Update all uses. (eieio--class-num-slots, eieio--object-num-slots): Rename from class-num-slots and object-num-slots. (eieio--check-type): New macro. (eieio-defclass, eieio-oref, eieio-oref-default, same-class-p) (object-of-class-p, child-of-class-p, object-slots, class-slot-initarg) (eieio-oset, eieio-oset-default, object-assoc, object-assoc-list) (object-assoc-list-safe): Use it. (eieio-defclass): Tighten regexp. (eieio--defmethod): Use `memq'. Signal an error for unknown method kind. Remove unreachable code. (object-class-fast): Declare obsolete. (eieio-class-name, eieio-object-name, eieio-object-set-name-string) (eieio-object-class, eieio-object-class-name, eieio-class-parents) (eieio-class-children, eieio-class-precedence-list, eieio-class-parent): Rename from class-name, object-name, object-set-name-string, object-class, object-class-name, class-parents, class-children, class-precedence-list, class-parent; with obsolete alias. (class-of, class-direct-superclasses, class-direct-subclasses): Declare obsolete. (eieio-defmethod): Use `memq'; remove unreachable code. * lisp/emacs-lisp/eieio-base.el (eieio-persistent-read): * lisp/emacs-lisp/eieio-opt.el (eieio-class-button, eieio-describe-generic) (eieio-browse-tree, eieio-browse): Use eieio--check-type.
Diffstat
-rw-r--r--lisp/ChangeLog31
-rw-r--r--lisp/emacs-lisp/eieio-base.el20
-rw-r--r--lisp/emacs-lisp/eieio-custom.el38
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el14
-rw-r--r--lisp/emacs-lisp/eieio-opt.el44
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el8
-rw-r--r--lisp/emacs-lisp/eieio.el691
7 files changed, 448 insertions, 398 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b1d1c1e7fd0..d4832d9cce8 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,34 @@
12013-02-19 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 Cleanup some of EIEIO's namespace.
4 * emacs-lisp/eieio.el (eieio--define-field-accessors): New macro.
5 Use it to define all the class-* and object-* field accessors (renamed
6 to eieio--class-* and eieio--object-*). Update all uses.
7 (eieio--class-num-slots, eieio--object-num-slots): Rename from
8 class-num-slots and object-num-slots.
9 (eieio--check-type): New macro.
10 (eieio-defclass, eieio-oref, eieio-oref-default, same-class-p)
11 (object-of-class-p, child-of-class-p, object-slots, class-slot-initarg)
12 (eieio-oset, eieio-oset-default, object-assoc, object-assoc-list)
13 (object-assoc-list-safe): Use it.
14 (eieio-defclass): Tighten regexp.
15 (eieio--defmethod): Use `memq'. Signal an error for unknown method kind.
16 Remove unreachable code.
17 (object-class-fast): Declare obsolete.
18 (eieio-class-name, eieio-object-name, eieio-object-set-name-string)
19 (eieio-object-class, eieio-object-class-name, eieio-class-parents)
20 (eieio-class-children, eieio-class-precedence-list, eieio-class-parent):
21 Rename from class-name, object-name, object-set-name-string,
22 object-class, object-class-name, class-parents, class-children,
23 class-precedence-list, class-parent; with obsolete alias.
24 (class-of, class-direct-superclasses, class-direct-subclasses):
25 Declare obsolete.
26 (eieio-defmethod): Use `memq'; remove unreachable code.
27 * emacs-lisp/eieio-base.el (eieio-persistent-read):
28 * emacs-lisp/eieio-opt.el (eieio-class-button, eieio-describe-generic)
29 (eieio-browse-tree, eieio-browse): Use eieio--check-type.
30
31
12013-02-18 Michael Heerdegen <michael_heerdegen@web.de> 322013-02-18 Michael Heerdegen <michael_heerdegen@web.de>
2 33
3 * emacs-lisp/eldoc.el (eldoc-highlight-function-argument): 34 * emacs-lisp/eldoc.el (eldoc-highlight-function-argument):
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 24d680181bb..c8ae3f4bf1a 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -65,19 +65,19 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
65 "Clone OBJ, initializing `:parent' to OBJ. 65 "Clone OBJ, initializing `:parent' to OBJ.
66All slots are unbound, except those initialized with PARAMS." 66All slots are unbound, except those initialized with PARAMS."
67 (let ((nobj (make-vector (length obj) eieio-unbound)) 67 (let ((nobj (make-vector (length obj) eieio-unbound))
68 (nm (aref obj object-name)) 68 (nm (eieio--object-name obj))
69 (passname (and params (stringp (car params)))) 69 (passname (and params (stringp (car params))))
70 (num 1)) 70 (num 1))
71 (aset nobj 0 'object) 71 (aset nobj 0 'object)
72 (aset nobj object-class (aref obj object-class)) 72 (setf (eieio--object-class nobj) (eieio--object-class obj))
73 ;; The following was copied from the default clone. 73 ;; The following was copied from the default clone.
74 (if (not passname) 74 (if (not passname)
75 (save-match-data 75 (save-match-data
76 (if (string-match "-\\([0-9]+\\)" nm) 76 (if (string-match "-\\([0-9]+\\)" nm)
77 (setq num (1+ (string-to-number (match-string 1 nm))) 77 (setq num (1+ (string-to-number (match-string 1 nm)))
78 nm (substring nm 0 (match-beginning 0)))) 78 nm (substring nm 0 (match-beginning 0))))
79 (aset nobj object-name (concat nm "-" (int-to-string num)))) 79 (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
80 (aset nobj object-name (car params))) 80 (setf (eieio--object-name nobj) (car params)))
81 ;; Now initialize from params. 81 ;; Now initialize from params.
82 (if params (shared-initialize nobj (if passname (cdr params) params))) 82 (if params (shared-initialize nobj (if passname (cdr params) params)))
83 (oset nobj parent-instance obj) 83 (oset nobj parent-instance obj)
@@ -232,8 +232,7 @@ for CLASS. Optional ALLOW-SUBCLASS says that it is ok for
232being pedantic." 232being pedantic."
233 (unless class 233 (unless class
234 (message "Unsafe call to `eieio-persistent-read'.")) 234 (message "Unsafe call to `eieio-persistent-read'."))
235 (when (and class (not (class-p class))) 235 (when class (eieio--check-type class-p class))
236 (signal 'wrong-type-argument (list 'class-p class)))
237 (let ((ret nil) 236 (let ((ret nil)
238 (buffstr nil)) 237 (buffstr nil))
239 (unwind-protect 238 (unwind-protect
@@ -308,7 +307,7 @@ Second, any text properties will be stripped from strings."
308 (type nil) 307 (type nil)
309 (classtype nil)) 308 (classtype nil))
310 (setq slot-idx (- slot-idx 3)) 309 (setq slot-idx (- slot-idx 3))
311 (setq type (aref (aref (class-v class) class-public-type) 310 (setq type (aref (eieio--class-public-type (class-v class))
312 slot-idx)) 311 slot-idx))
313 312
314 (setq classtype (eieio-persistent-slot-type-is-class-p 313 (setq classtype (eieio-persistent-slot-type-is-class-p
@@ -482,14 +481,13 @@ Argument SLOT-NAME is the slot that was attempted to be accessed.
482OPERATION is the type of access, such as `oref' or `oset'. 481OPERATION is the type of access, such as `oref' or `oset'.
483NEW-VALUE is the value that was being set into SLOT if OPERATION were 482NEW-VALUE is the value that was being set into SLOT if OPERATION were
484a set type." 483a set type."
485 (if (or (eq slot-name 'object-name) 484 (if (memq slot-name '(object-name :object-name))
486 (eq slot-name :object-name))
487 (cond ((eq operation 'oset) 485 (cond ((eq operation 'oset)
488 (if (not (stringp new-value)) 486 (if (not (stringp new-value))
489 (signal 'invalid-slot-type 487 (signal 'invalid-slot-type
490 (list obj slot-name 'string new-value))) 488 (list obj slot-name 'string new-value)))
491 (object-set-name-string obj new-value)) 489 (eieio-object-set-name-string obj new-value))
492 (t (object-name-string obj))) 490 (t (eieio-object-name-string obj)))
493 (call-next-method))) 491 (call-next-method)))
494 492
495(provide 'eieio-base) 493(provide 'eieio-base)
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 46dc34d6d45..f9917bddd42 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -192,22 +192,22 @@ Optional argument IGNORE is an extraneous parameter."
192 (let* ((chil nil) 192 (let* ((chil nil)
193 (obj (widget-get widget :value)) 193 (obj (widget-get widget :value))
194 (master-group (widget-get widget :eieio-group)) 194 (master-group (widget-get widget :eieio-group))
195 (cv (class-v (object-class-fast obj))) 195 (cv (class-v (eieio--object-class obj)))
196 (slots (aref cv class-public-a)) 196 (slots (eieio--class-public-a cv))
197 (flabel (aref cv class-public-custom-label)) 197 (flabel (eieio--class-public-custom-label cv))
198 (fgroup (aref cv class-public-custom-group)) 198 (fgroup (eieio--class-public-custom-group cv))
199 (fdoc (aref cv class-public-doc)) 199 (fdoc (eieio--class-public-doc cv))
200 (fcust (aref cv class-public-custom))) 200 (fcust (eieio--class-public-custom cv)))
201 ;; First line describes the object, but may not editable. 201 ;; First line describes the object, but may not editable.
202 (if (widget-get widget :eieio-show-name) 202 (if (widget-get widget :eieio-show-name)
203 (setq chil (cons (widget-create-child-and-convert 203 (setq chil (cons (widget-create-child-and-convert
204 widget 'string :tag "Object " 204 widget 'string :tag "Object "
205 :sample-face 'bold 205 :sample-face 'bold
206 (object-name-string obj)) 206 (eieio-object-name-string obj))
207 chil))) 207 chil)))
208 ;; Display information about the group being shown 208 ;; Display information about the group being shown
209 (when master-group 209 (when master-group
210 (let ((groups (class-option (object-class-fast obj) :custom-groups))) 210 (let ((groups (class-option (eieio--object-class obj) :custom-groups)))
211 (widget-insert "Groups:") 211 (widget-insert "Groups:")
212 (while groups 212 (while groups
213 (widget-insert " ") 213 (widget-insert " ")
@@ -260,7 +260,7 @@ Optional argument IGNORE is an extraneous parameter."
260 (let ((s (symbol-name 260 (let ((s (symbol-name
261 (or 261 (or
262 (class-slot-initarg 262 (class-slot-initarg
263 (object-class-fast obj) 263 (eieio--object-class obj)
264 (car slots)) 264 (car slots))
265 (car slots))))) 265 (car slots)))))
266 (capitalize 266 (capitalize
@@ -287,17 +287,17 @@ Optional argument IGNORE is an extraneous parameter."
287 "Get the value of WIDGET." 287 "Get the value of WIDGET."
288 (let* ((obj (widget-get widget :value)) 288 (let* ((obj (widget-get widget :value))
289 (master-group eieio-cog) 289 (master-group eieio-cog)
290 (cv (class-v (object-class-fast obj))) 290 (cv (class-v (eieio--object-class obj)))
291 (fgroup (aref cv class-public-custom-group)) 291 (fgroup (eieio--class-public-custom-group cv))
292 (wids (widget-get widget :children)) 292 (wids (widget-get widget :children))
293 (name (if (widget-get widget :eieio-show-name) 293 (name (if (widget-get widget :eieio-show-name)
294 (car (widget-apply (car wids) :value-inline)) 294 (car (widget-apply (car wids) :value-inline))
295 nil)) 295 nil))
296 (chil (if (widget-get widget :eieio-show-name) 296 (chil (if (widget-get widget :eieio-show-name)
297 (nthcdr 1 wids) wids)) 297 (nthcdr 1 wids) wids))
298 (cv (class-v (object-class-fast obj))) 298 (cv (class-v (eieio--object-class obj)))
299 (slots (aref cv class-public-a)) 299 (slots (eieio--class-public-a cv))
300 (fcust (aref cv class-public-custom))) 300 (fcust (eieio--class-public-custom cv)))
301 ;; If there are any prefix widgets, clear them. 301 ;; If there are any prefix widgets, clear them.
302 ;; -- None yet 302 ;; -- None yet
303 ;; Create a batch of initargs for each slot. 303 ;; Create a batch of initargs for each slot.
@@ -316,7 +316,7 @@ Optional argument IGNORE is an extraneous parameter."
316 fgroup (cdr fgroup) 316 fgroup (cdr fgroup)
317 fcust (cdr fcust))) 317 fcust (cdr fcust)))
318 ;; Set any name updates on it. 318 ;; Set any name updates on it.
319 (if name (aset obj object-name name)) 319 (if name (setf (eieio--object-name obj) name))
320 ;; This is the same object we had before. 320 ;; This is the same object we had before.
321 obj)) 321 obj))
322 322
@@ -354,7 +354,7 @@ These groups are specified with the `:group' slot flag."
354 (let* ((g (or group 'default))) 354 (let* ((g (or group 'default)))
355 (switch-to-buffer (get-buffer-create 355 (switch-to-buffer (get-buffer-create
356 (concat "*CUSTOMIZE " 356 (concat "*CUSTOMIZE "
357 (object-name obj) " " 357 (eieio-object-name obj) " "
358 (symbol-name g) "*"))) 358 (symbol-name g) "*")))
359 (setq buffer-read-only nil) 359 (setq buffer-read-only nil)
360 (kill-all-local-variables) 360 (kill-all-local-variables)
@@ -367,7 +367,7 @@ These groups are specified with the `:group' slot flag."
367 ;; Add an apply reset option at the top of the buffer. 367 ;; Add an apply reset option at the top of the buffer.
368 (eieio-custom-object-apply-reset obj) 368 (eieio-custom-object-apply-reset obj)
369 (widget-insert "\n\n") 369 (widget-insert "\n\n")
370 (widget-insert "Edit object " (object-name obj) "\n\n") 370 (widget-insert "Edit object " (eieio-object-name obj) "\n\n")
371 ;; Create the widget editing the object. 371 ;; Create the widget editing the object.
372 (make-local-variable 'eieio-wo) 372 (make-local-variable 'eieio-wo)
373 (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) 373 (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
@@ -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 (object-class-fast obj) :custom-groups))) 455 (class-option (eieio--object-class 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,7 @@ 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 (object-class-fast obj) :custom-groups))) 463 (let ((g (class-option (eieio--object-class obj) :custom-groups)))
464 (if (= (length g) 1) 464 (if (= (length g) 1)
465 (car g) 465 (car g)
466 ;; Make the association list 466 ;; Make the association list
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index e23bbb07fe2..7daa24257a1 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -58,9 +58,9 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
58 (end nil) 58 (end nil)
59 (str (object-print object)) 59 (str (object-print object))
60 (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" 60 (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
61 (object-name-string object) 61 (eieio-object-name-string object)
62 (object-class object) 62 (eieio-object-class object)
63 (class-parents (object-class object)) 63 (eieio-class-parents (eieio-object-class object))
64 (length (object-slots object)) 64 (length (object-slots object))
65 )) 65 ))
66 ) 66 )
@@ -82,16 +82,16 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
82(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) 82(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
83 prefix) 83 prefix)
84 "Insert the slots of OBJ into the current DDEBUG buffer." 84 "Insert the slots of OBJ into the current DDEBUG buffer."
85 (data-debug-insert-thing (object-name-string obj) 85 (data-debug-insert-thing (eieio-object-name-string obj)
86 prefix 86 prefix
87 "Name: ") 87 "Name: ")
88 (let* ((cl (object-class obj)) 88 (let* ((cl (eieio-object-class obj))
89 (cv (class-v cl))) 89 (cv (class-v cl)))
90 (data-debug-insert-thing (class-constructor cl) 90 (data-debug-insert-thing (class-constructor cl)
91 prefix 91 prefix
92 "Class: ") 92 "Class: ")
93 ;; Loop over all the public slots 93 ;; Loop over all the public slots
94 (let ((publa (aref cv class-public-a)) 94 (let ((publa (eieio--class-public-a cv))
95 ) 95 )
96 (while publa 96 (while publa
97 (if (slot-boundp obj (car publa)) 97 (if (slot-boundp obj (car publa))
@@ -123,7 +123,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
123;; 123;;
124(defmethod data-debug-show ((obj eieio-default-superclass)) 124(defmethod data-debug-show ((obj eieio-default-superclass))
125 "Run ddebug against any EIEIO object OBJ." 125 "Run ddebug against any EIEIO object OBJ."
126 (data-debug-new-buffer (format "*%s DDEBUG*" (object-name obj))) 126 (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
127 (data-debug-insert-object-slots obj "]")) 127 (data-debug-insert-object-slots obj "]"))
128 128
129;;; DEBUG FUNCTIONS 129;;; DEBUG FUNCTIONS
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 8867d88cc3a..29ad980991b 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -45,7 +45,7 @@ variable `eieio-default-superclass'."
45 nil t))) 45 nil t)))
46 nil)) 46 nil))
47 (if (not root-class) (setq root-class 'eieio-default-superclass)) 47 (if (not root-class) (setq root-class 'eieio-default-superclass))
48 (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class))) 48 (eieio--check-type class-p root-class)
49 (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) 49 (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
50 (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") 50 (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*")
51 (erase-buffer) 51 (erase-buffer)
@@ -58,9 +58,9 @@ variable `eieio-default-superclass'."
58Argument THIS-ROOT is the local root of the tree. 58Argument THIS-ROOT is the local root of the tree.
59Argument PREFIX is the character prefix to use. 59Argument PREFIX is the character prefix to use.
60Argument CH-PREFIX is another character prefix to display." 60Argument CH-PREFIX is another character prefix to display."
61 (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root))) 61 (eieio--check-type class-p this-root)
62 (let ((myname (symbol-name this-root)) 62 (let ((myname (symbol-name this-root))
63 (chl (aref (class-v this-root) class-children)) 63 (chl (eieio--class-children (class-v this-root)))
64 (fprefix (concat ch-prefix " +--")) 64 (fprefix (concat ch-prefix " +--"))
65 (mprefix (concat ch-prefix " | ")) 65 (mprefix (concat ch-prefix " | "))
66 (lprefix (concat ch-prefix " "))) 66 (lprefix (concat ch-prefix " ")))
@@ -99,7 +99,7 @@ Optional HEADERFCN should be called to insert a few bits of info first."
99 (princ "'")) 99 (princ "'"))
100 (terpri) 100 (terpri)
101 ;; Inheritance tree information 101 ;; Inheritance tree information
102 (let ((pl (class-parents class))) 102 (let ((pl (eieio-class-parents class)))
103 (when pl 103 (when pl
104 (princ " Inherits from ") 104 (princ " Inherits from ")
105 (while pl 105 (while pl
@@ -107,7 +107,7 @@ Optional HEADERFCN should be called to insert a few bits of info first."
107 (setq pl (cdr pl)) 107 (setq pl (cdr pl))
108 (if pl (princ ", "))) 108 (if pl (princ ", ")))
109 (terpri))) 109 (terpri)))
110 (let ((ch (class-children class))) 110 (let ((ch (eieio-class-children class)))
111 (when ch 111 (when ch
112 (princ " Children ") 112 (princ " Children ")
113 (while ch 113 (while ch
@@ -177,13 +177,13 @@ Optional HEADERFCN should be called to insert a few bits of info first."
177 "Describe the slots in CLASS. 177 "Describe the slots in CLASS.
178Outputs to the standard output." 178Outputs to the standard output."
179 (let* ((cv (class-v class)) 179 (let* ((cv (class-v class))
180 (docs (aref cv class-public-doc)) 180 (docs (eieio--class-public-doc cv))
181 (names (aref cv class-public-a)) 181 (names (eieio--class-public-a cv))
182 (deflt (aref cv class-public-d)) 182 (deflt (eieio--class-public-d cv))
183 (types (aref cv class-public-type)) 183 (types (eieio--class-public-type cv))
184 (publp (aref cv class-public-printer)) 184 (publp (eieio--class-public-printer cv))
185 (i 0) 185 (i 0)
186 (prot (aref cv class-protection)) 186 (prot (eieio--class-protection cv))
187 ) 187 )
188 (princ "Instance Allocated Slots:") 188 (princ "Instance Allocated Slots:")
189 (terpri) 189 (terpri)
@@ -213,11 +213,11 @@ Outputs to the standard output."
213 publp (cdr publp) 213 publp (cdr publp)
214 prot (cdr prot) 214 prot (cdr prot)
215 i (1+ i))) 215 i (1+ i)))
216 (setq docs (aref cv class-class-allocation-doc) 216 (setq docs (eieio--class-class-allocation-doc cv)
217 names (aref cv class-class-allocation-a) 217 names (eieio--class-class-allocation-a cv)
218 types (aref cv class-class-allocation-type) 218 types (eieio--class-class-allocation-type cv)
219 i 0 219 i 0
220 prot (aref cv class-class-allocation-protection)) 220 prot (eieio--class-class-allocation-protection cv))
221 (when names 221 (when names
222 (terpri) 222 (terpri)
223 (princ "Class Allocated Slots:")) 223 (princ "Class Allocated Slots:"))
@@ -281,7 +281,7 @@ Uses `eieio-describe-class' to describe the class being constructed."
281 (mapcar 281 (mapcar
282 (lambda (c) 282 (lambda (c)
283 (append (list c) (eieio-build-class-list c))) 283 (append (list c) (eieio-build-class-list c)))
284 (class-children-fast class))) 284 (eieio-class-children-fast class)))
285 (list class))) 285 (list class)))
286 286
287(defun eieio-build-class-alist (&optional class instantiable-only buildlist) 287(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
@@ -291,7 +291,7 @@ If INSTANTIABLE-ONLY is non nil, only allow names of classes which
291are not abstract, otherwise allow all classes. 291are not abstract, otherwise allow all classes.
292Optional argument BUILDLIST is more list to attach and is used internally." 292Optional argument BUILDLIST is more list to attach and is used internally."
293 (let* ((cc (or class eieio-default-superclass)) 293 (let* ((cc (or class eieio-default-superclass))
294 (sublst (aref (class-v cc) class-children))) 294 (sublst (eieio--class-children (class-v cc))))
295 (unless (assoc (symbol-name cc) buildlist) 295 (unless (assoc (symbol-name cc) buildlist)
296 (when (or (not instantiable-only) (not (class-abstract-p cc))) 296 (when (or (not instantiable-only) (not (class-abstract-p cc)))
297 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) 297 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
@@ -335,8 +335,7 @@ are not abstract."
335 "Describe the generic function GENERIC. 335 "Describe the generic function GENERIC.
336Also extracts information about all methods specific to this generic." 336Also extracts information about all methods specific to this generic."
337 (interactive (list (eieio-read-generic "Generic Method: "))) 337 (interactive (list (eieio-read-generic "Generic Method: ")))
338 (if (not (generic-p generic)) 338 (eieio--check-type generic-p generic)
339 (signal 'wrong-type-argument '(generic-p generic)))
340 (with-output-to-temp-buffer (help-buffer) ; "*Help*" 339 (with-output-to-temp-buffer (help-buffer) ; "*Help*"
341 (help-setup-xref (list #'eieio-describe-generic generic) 340 (help-setup-xref (list #'eieio-describe-generic generic)
342 (called-interactively-p 'interactive)) 341 (called-interactively-p 'interactive))
@@ -757,9 +756,8 @@ current expansion depth."
757 756
758(defun eieio-class-button (class depth) 757(defun eieio-class-button (class depth)
759 "Draw a speedbar button at the current point for CLASS at DEPTH." 758 "Draw a speedbar button at the current point for CLASS at DEPTH."
760 (if (not (class-p class)) 759 (eieio--check-type class-p class)
761 (signal 'wrong-type-argument (list 'class-p class))) 760 (let ((subclasses (eieio--class-children (class-v class))))
762 (let ((subclasses (aref (class-v class) class-children)))
763 (if subclasses 761 (if subclasses
764 (speedbar-make-tag-line 'angle ?+ 762 (speedbar-make-tag-line 'angle ?+
765 'eieio-sb-expand 763 'eieio-sb-expand
@@ -784,7 +782,7 @@ Argument INDENT is the depth of indentation."
784 (speedbar-with-writable 782 (speedbar-with-writable
785 (save-excursion 783 (save-excursion
786 (end-of-line) (forward-char 1) 784 (end-of-line) (forward-char 1)
787 (let ((subclasses (aref (class-v class) class-children))) 785 (let ((subclasses (eieio--class-children (class-v class))))
788 (while subclasses 786 (while subclasses
789 (eieio-class-button (car subclasses) (1+ indent)) 787 (eieio-class-button (car subclasses) (1+ indent))
790 (setq subclasses (cdr subclasses))))))) 788 (setq subclasses (cdr subclasses)))))))
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index 27c7d01f3b8..c230226eae4 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -198,7 +198,7 @@ that path."
198 198
199(defmethod eieio-speedbar-description (object) 199(defmethod eieio-speedbar-description (object)
200 "Return a string describing OBJECT." 200 "Return a string describing OBJECT."
201 (object-name-string object)) 201 (eieio-object-name-string object))
202 202
203(defmethod eieio-speedbar-derive-line-path (object) 203(defmethod eieio-speedbar-derive-line-path (object)
204 "Return the path which OBJECT has something to do with." 204 "Return the path which OBJECT has something to do with."
@@ -206,7 +206,7 @@ that path."
206 206
207(defmethod eieio-speedbar-object-buttonname (object) 207(defmethod eieio-speedbar-object-buttonname (object)
208 "Return a string to use as a speedbar button for OBJECT." 208 "Return a string to use as a speedbar button for OBJECT."
209 (object-name-string object)) 209 (eieio-object-name-string object))
210 210
211(defmethod eieio-speedbar-make-tag-line (object depth) 211(defmethod eieio-speedbar-make-tag-line (object depth)
212 "Insert a tag line into speedbar at point for OBJECT. 212 "Insert a tag line into speedbar at point for OBJECT.
@@ -324,7 +324,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
324(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) 324(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth)
325 "Base method for creating tag lines for non-object children." 325 "Base method for creating tag lines for non-object children."
326 (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" 326 (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
327 (object-name object))) 327 (eieio-object-name object)))
328 328
329(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) 329(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
330 "Expand OBJECT at indentation DEPTH. 330 "Expand OBJECT at indentation DEPTH.
@@ -365,7 +365,7 @@ TOKEN is the object. INDENT is the current indentation level."
365(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) 365(defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
366 "Return a description for a child of OBJ which is not an object." 366 "Return a description for a child of OBJ which is not an object."
367 (error "You must implement `eieio-speedbar-child-description' for %s" 367 (error "You must implement `eieio-speedbar-child-description' for %s"
368 (object-name obj))) 368 (eieio-object-name obj)))
369 369
370(defun eieio-speedbar-item-info () 370(defun eieio-speedbar-item-info ()
371 "Display info for the current line when in EDE display mode." 371 "Display info for the current line when in EDE display mode."
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 626bc0f6dc6..37b1ec5fa94 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -105,49 +105,67 @@ default setting for optimization purposes.")
105 105
106;; This is a bootstrap for eieio-default-superclass so it has a value 106;; This is a bootstrap for eieio-default-superclass so it has a value
107;; while it is being built itself. 107;; while it is being built itself.
108(defvar eieio-default-superclass nil) 108(defvar eieio-default-superclass nil))
109 109
110;; FIXME: The constants below should have an `eieio-' prefix added!! 110(defmacro eieio--define-field-accessors (prefix fields)
111(defconst class-symbol 1 "Class's symbol (self-referencing.).") 111 (declare (indent 1))
112(defconst class-parent 2 "Class parent slot.") 112 (let ((index 0)
113(defconst class-children 3 "Class children class slot.") 113 (defs '()))
114(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.") 114 (dolist (field fields)
115;; @todo 115 (let ((doc (if (listp field)
116;; the word "public" here is leftovers from the very first version. 116 (prog1 (cadr field) (setq field (car field))))))
117;; Get rid of it! 117 (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x)
118(defconst class-public-a 5 "Class attribute index.") 118 ,@(if doc (list (format (if (string-match "\n" doc)
119(defconst class-public-d 6 "Class attribute defaults index.") 119 "Return %s" "Return %s of a %s.")
120(defconst class-public-doc 7 "Class documentation strings for attributes.") 120 doc prefix)))
121(defconst class-public-type 8 "Class type for a slot.") 121 (list 'aref x ,index))
122(defconst class-public-custom 9 "Class custom type for a slot.") 122 defs)
123(defconst class-public-custom-label 10 "Class custom group for a slot.") 123 (setq index (1+ index))))
124(defconst class-public-custom-group 11 "Class custom group for a slot.") 124 `(eval-and-compile
125(defconst class-public-printer 12 "Printer for a slot.") 125 ,@(nreverse defs)
126(defconst class-protection 13 "Class protection for a slot.") 126 (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index))))
127(defconst class-initarg-tuples 14 "Class initarg tuples list.") 127
128(defconst class-class-allocation-a 15 "Class allocated attributes.") 128(eieio--define-field-accessors class
129(defconst class-class-allocation-doc 16 "Class allocated documentation.") 129 (-unused-0 ;;FIXME: not sure, but at least there was no accessor!
130(defconst class-class-allocation-type 17 "Class allocated value type.") 130 (symbol "symbol (self-referencing)")
131(defconst class-class-allocation-custom 18 "Class allocated custom descriptor.") 131 parent children
132(defconst class-class-allocation-custom-label 19 "Class allocated custom descriptor.") 132 (symbol-obarray "obarray permitting fast access to variable position indexes")
133(defconst class-class-allocation-custom-group 20 "Class allocated custom group.") 133 ;; @todo
134(defconst class-class-allocation-printer 21 "Class allocated printer for a slot.") 134 ;; the word "public" here is leftovers from the very first version.
135(defconst class-class-allocation-protection 22 "Class allocated protection list.") 135 ;; Get rid of it!
136(defconst class-class-allocation-values 23 "Class allocated value vector.") 136 (public-a "class attribute index")
137(defconst class-default-object-cache 24 137 (public-d "class attribute defaults index")
138 "Cache index of what a newly created object would look like. 138 (public-doc "class documentation strings for attributes")
139 (public-type "class type for a slot")
140 (public-custom "class custom type for a slot")
141 (public-custom-label "class custom group for a slot")
142 (public-custom-group "class custom group for a slot")
143 (public-printer "printer for a slot")
144 (protection "protection for a slot")
145 (initarg-tuples "initarg tuples list")
146 (class-allocation-a "class allocated attributes")
147 (class-allocation-doc "class allocated documentation")
148 (class-allocation-type "class allocated value type")
149 (class-allocation-custom "class allocated custom descriptor")
150 (class-allocation-custom-label "class allocated custom descriptor")
151 (class-allocation-custom-group "class allocated custom group")
152 (class-allocation-printer "class allocated printer for a slot")
153 (class-allocation-protection "class allocated protection list")
154 (class-allocation-values "class allocated value vector")
155 (default-object-cache "what a newly created object would look like.
139This will speed up instantiation time as only a `copy-sequence' will 156This will speed up instantiation time as only a `copy-sequence' will
140be needed, instead of looping over all the values and setting them 157be needed, instead of looping over all the values and setting them
141from the default.") 158from the default.")
142(defconst class-options 25 159 (options "storage location of tagged class options.
143 "Storage location of tagged class options. 160Stored outright without modifications or stripping.")))
144Stored outright without modifications or stripping.")
145 161
146(defconst class-num-slots 26 162(eieio--define-field-accessors object
147 "Number of slots in the class definition object.") 163 (-unused-0 ;;FIXME: not sure, but at least there was no accessor!
164 (class "class struct defining OBJ")
165 name))
148 166
149(defconst object-class 1 "Index in an object vector where the class is stored.") 167(eval-and-compile
150(defconst object-name 2 "Index in an object where the name is stored.") 168;; FIXME: The constants below should have an `eieio-' prefix added!!
151 169
152(defconst method-static 0 "Index into :static tag on a method.") 170(defconst method-static 0 "Index into :static tag on a method.")
153(defconst method-before 1 "Index into :before tag on a method.") 171(defconst method-before 1 "Index into :before tag on a method.")
@@ -188,13 +206,13 @@ CLASS is a symbol."
188 `(condition-case nil 206 `(condition-case nil
189 (let ((tobj ,obj)) 207 (let ((tobj ,obj))
190 (and (eq (aref tobj 0) 'object) 208 (and (eq (aref tobj 0) 'object)
191 (class-p (aref tobj object-class)))) 209 (class-p (eieio--object-class tobj))))
192 (error nil))) 210 (error nil)))
193(defalias 'object-p 'eieio-object-p) 211(defalias 'object-p 'eieio-object-p)
194 212
195(defmacro class-constructor (class) 213(defmacro class-constructor (class)
196 "Return the symbol representing the constructor of CLASS." 214 "Return the symbol representing the constructor of CLASS."
197 `(aref (class-v ,class) class-symbol)) 215 `(eieio--class-symbol (class-v ,class)))
198 216
199(defmacro generic-p (method) 217(defmacro generic-p (method)
200 "Return t if symbol METHOD is a generic function. 218 "Return t if symbol METHOD is a generic function.
@@ -241,7 +259,7 @@ Methods with only primary implementations are executed in an optimized way."
241(defmacro class-option (class option) 259(defmacro class-option (class option)
242 "Return the value stored for CLASS' OPTION. 260 "Return the value stored for CLASS' OPTION.
243Return nil if that option doesn't exist." 261Return nil if that option doesn't exist."
244 `(class-option-assoc (aref (class-v ,class) class-options) ',option)) 262 `(class-option-assoc (eieio--class-options (class-v ,class)) ',option))
245 263
246(defmacro class-abstract-p (class) 264(defmacro class-abstract-p (class)
247 "Return non-nil if CLASS is abstract. 265 "Return non-nil if CLASS is abstract.
@@ -334,14 +352,14 @@ It creates an autoload function for CNAME's constructor."
334 ;; Assume we've already debugged inputs. 352 ;; Assume we've already debugged inputs.
335 353
336 (let* ((oldc (when (class-p cname) (class-v cname))) 354 (let* ((oldc (when (class-p cname) (class-v cname)))
337 (newc (make-vector class-num-slots nil)) 355 (newc (make-vector eieio--class-num-slots nil))
338 ) 356 )
339 (if oldc 357 (if oldc
340 nil ;; Do nothing if we already have this class. 358 nil ;; Do nothing if we already have this class.
341 359
342 ;; Create the class in NEWC, but don't fill anything else in. 360 ;; Create the class in NEWC, but don't fill anything else in.
343 (aset newc 0 'defclass) 361 (aset newc 0 'defclass)
344 (aset newc class-symbol cname) 362 (setf (eieio--class-symbol newc) cname)
345 363
346 (let ((clear-parent nil)) 364 (let ((clear-parent nil))
347 ;; No parents? 365 ;; No parents?
@@ -371,12 +389,12 @@ It creates an autoload function for CNAME's constructor."
371 ) 389 )
372 390
373 ;; We have a parent, save the child in there. 391 ;; We have a parent, save the child in there.
374 (when (not (member cname (aref (class-v SC) class-children))) 392 (when (not (member cname (eieio--class-children (class-v SC))))
375 (aset (class-v SC) class-children 393 (setf (eieio--class-children (class-v SC))
376 (cons cname (aref (class-v SC) class-children))))) 394 (cons cname (eieio--class-children (class-v SC))))))
377 395
378 ;; save parent in child 396 ;; save parent in child
379 (aset newc class-parent (cons SC (aref newc class-parent))) 397 (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc)))
380 ) 398 )
381 399
382 ;; turn this into a usable self-pointing symbol 400 ;; turn this into a usable self-pointing symbol
@@ -389,7 +407,7 @@ It creates an autoload function for CNAME's constructor."
389 (put cname 'eieio-class-definition newc) 407 (put cname 'eieio-class-definition newc)
390 408
391 ;; Clear the parent 409 ;; Clear the parent
392 (if clear-parent (aset newc class-parent nil)) 410 (if clear-parent (setf (eieio--class-parent newc) nil))
393 411
394 ;; Create an autoload on top of our constructor function. 412 ;; Create an autoload on top of our constructor function.
395 (autoload cname filename doc nil nil) 413 (autoload cname filename doc nil nil)
@@ -404,6 +422,15 @@ It creates an autoload function for CNAME's constructor."
404 (when (eq (car-safe (symbol-function cname)) 'autoload) 422 (when (eq (car-safe (symbol-function cname)) 'autoload)
405 (load-library (car (cdr (symbol-function cname)))))) 423 (load-library (car (cdr (symbol-function cname))))))
406 424
425(defmacro eieio--check-type (type obj)
426 (unless (symbolp obj)
427 (error "eieio--check-type wants OBJ to be a variable"))
428 `(if (not ,(cond
429 ((eq 'or (car-safe type))
430 `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type))))
431 (t `(,type ,obj))))
432 (signal 'wrong-type-argument (list ',type ,obj))))
433
407(defun eieio-defclass (cname superclasses slots options-and-doc) 434(defun eieio-defclass (cname superclasses slots options-and-doc)
408 ;; FIXME: Most of this should be moved to the `defclass' macro. 435 ;; FIXME: Most of this should be moved to the `defclass' macro.
409 "Define CNAME as a new subclass of SUPERCLASSES. 436 "Define CNAME as a new subclass of SUPERCLASSES.
@@ -416,18 +443,17 @@ See `defclass' for more information."
416 (run-hooks 'eieio-hook) 443 (run-hooks 'eieio-hook)
417 (setq eieio-hook nil) 444 (setq eieio-hook nil)
418 445
419 (if (not (listp superclasses)) 446 (eieio--check-type listp superclasses)
420 (signal 'wrong-type-argument '(listp superclasses)))
421 447
422 (let* ((pname superclasses) 448 (let* ((pname superclasses)
423 (newc (make-vector class-num-slots nil)) 449 (newc (make-vector eieio--class-num-slots nil))
424 (oldc (when (class-p cname) (class-v cname))) 450 (oldc (when (class-p cname) (class-v cname)))
425 (groups nil) ;; list of groups id'd from slots 451 (groups nil) ;; list of groups id'd from slots
426 (options nil) 452 (options nil)
427 (clearparent nil)) 453 (clearparent nil))
428 454
429 (aset newc 0 'defclass) 455 (aset newc 0 'defclass)
430 (aset newc class-symbol cname) 456 (setf (eieio--class-symbol newc) cname)
431 457
432 ;; If this class already existed, and we are updating its structure, 458 ;; If this class already existed, and we are updating its structure,
433 ;; make sure we keep the old child list. This can cause bugs, but 459 ;; make sure we keep the old child list. This can cause bugs, but
@@ -435,13 +461,13 @@ See `defclass' for more information."
435 ;; method table breakage, particularly when the users is only 461 ;; method table breakage, particularly when the users is only
436 ;; byte compiling an EIEIO file. 462 ;; byte compiling an EIEIO file.
437 (if oldc 463 (if oldc
438 (aset newc class-children (aref oldc class-children)) 464 (setf (eieio--class-children newc) (eieio--class-children oldc))
439 ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. 465 ;; If the old class did not exist, but did exist in the autoload map, then adopt those children.
440 ;; This is like the above, but deals with autoloads nicely. 466 ;; This is like the above, but deals with autoloads nicely.
441 (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) 467 (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map)))
442 (when sym 468 (when sym
443 (condition-case nil 469 (condition-case nil
444 (aset newc class-children (symbol-value sym)) 470 (setf (eieio--class-children newc) (symbol-value sym))
445 (error nil)) 471 (error nil))
446 (unintern (symbol-name cname) eieio-defclass-autoload-map) 472 (unintern (symbol-name cname) eieio-defclass-autoload-map)
447 )) 473 ))
@@ -469,30 +495,30 @@ See `defclass' for more information."
469 (error "Given parent class %s is not a class" (car pname)) 495 (error "Given parent class %s is not a class" (car pname))
470 ;; good parent class... 496 ;; good parent class...
471 ;; save new child in parent 497 ;; save new child in parent
472 (when (not (member cname (aref (class-v (car pname)) class-children))) 498 (when (not (member cname (eieio--class-children (class-v (car pname)))))
473 (aset (class-v (car pname)) class-children 499 (setf (eieio--class-children (class-v (car pname)))
474 (cons cname (aref (class-v (car pname)) class-children)))) 500 (cons cname (eieio--class-children (class-v (car pname))))))
475 ;; Get custom groups, and store them into our local copy. 501 ;; Get custom groups, and store them into our local copy.
476 (mapc (lambda (g) (add-to-list 'groups g)) 502 (mapc (lambda (g) (add-to-list 'groups g))
477 (class-option (car pname) :custom-groups)) 503 (class-option (car pname) :custom-groups))
478 ;; save parent in child 504 ;; save parent in child
479 (aset newc class-parent (cons (car pname) (aref newc class-parent)))) 505 (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc))))
480 (error "Invalid parent class %s" pname)) 506 (error "Invalid parent class %s" pname))
481 (setq pname (cdr pname))) 507 (setq pname (cdr pname)))
482 ;; Reverse the list of our parents so that they are prioritized in 508 ;; Reverse the list of our parents so that they are prioritized in
483 ;; the same order as specified in the code. 509 ;; the same order as specified in the code.
484 (aset newc class-parent (nreverse (aref newc class-parent))) ) 510 (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) )
485 ;; If there is nothing to loop over, then inherit from the 511 ;; If there is nothing to loop over, then inherit from the
486 ;; default superclass. 512 ;; default superclass.
487 (unless (eq cname 'eieio-default-superclass) 513 (unless (eq cname 'eieio-default-superclass)
488 ;; adopt the default parent here, but clear it later... 514 ;; adopt the default parent here, but clear it later...
489 (setq clearparent t) 515 (setq clearparent t)
490 ;; save new child in parent 516 ;; save new child in parent
491 (if (not (member cname (aref (class-v 'eieio-default-superclass) class-children))) 517 (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass))))
492 (aset (class-v 'eieio-default-superclass) class-children 518 (setf (eieio--class-children (class-v 'eieio-default-superclass))
493 (cons cname (aref (class-v 'eieio-default-superclass) class-children)))) 519 (cons cname (eieio--class-children (class-v 'eieio-default-superclass)))))
494 ;; save parent in child 520 ;; save parent in child
495 (aset newc class-parent (list eieio-default-superclass)))) 521 (setf (eieio--class-parent newc) (list eieio-default-superclass))))
496 522
497 ;; turn this into a usable self-pointing symbol 523 ;; turn this into a usable self-pointing symbol
498 (set cname cname) 524 (set cname cname)
@@ -714,26 +740,26 @@ See `defclass' for more information."
714 740
715 ;; Now that everything has been loaded up, all our lists are backwards! 741 ;; Now that everything has been loaded up, all our lists are backwards!
716 ;; Fix that up now. 742 ;; Fix that up now.
717 (aset newc class-public-a (nreverse (aref newc class-public-a))) 743 (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc)))
718 (aset newc class-public-d (nreverse (aref newc class-public-d))) 744 (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc)))
719 (aset newc class-public-doc (nreverse (aref newc class-public-doc))) 745 (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc)))
720 (aset newc class-public-type 746 (setf (eieio--class-public-type newc)
721 (apply 'vector (nreverse (aref newc class-public-type)))) 747 (apply 'vector (nreverse (eieio--class-public-type newc))))
722 (aset newc class-public-custom (nreverse (aref newc class-public-custom))) 748 (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc)))
723 (aset newc class-public-custom-label (nreverse (aref newc class-public-custom-label))) 749 (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc)))
724 (aset newc class-public-custom-group (nreverse (aref newc class-public-custom-group))) 750 (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc)))
725 (aset newc class-public-printer (nreverse (aref newc class-public-printer))) 751 (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc)))
726 (aset newc class-protection (nreverse (aref newc class-protection))) 752 (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc)))
727 (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples))) 753 (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc)))
728 754
729 ;; The storage for class-class-allocation-type needs to be turned into 755 ;; The storage for class-class-allocation-type needs to be turned into
730 ;; a vector now. 756 ;; a vector now.
731 (aset newc class-class-allocation-type 757 (setf (eieio--class-class-allocation-type newc)
732 (apply 'vector (aref newc class-class-allocation-type))) 758 (apply 'vector (eieio--class-class-allocation-type newc)))
733 759
734 ;; Also, take class allocated values, and vectorize them for speed. 760 ;; Also, take class allocated values, and vectorize them for speed.
735 (aset newc class-class-allocation-values 761 (setf (eieio--class-class-allocation-values newc)
736 (apply 'vector (aref newc class-class-allocation-values))) 762 (apply 'vector (eieio--class-class-allocation-values newc)))
737 763
738 ;; Attach slot symbols into an obarray, and store the index of 764 ;; Attach slot symbols into an obarray, and store the index of
739 ;; this slot as the variable slot in this new symbol. We need to 765 ;; this slot as the variable slot in this new symbol. We need to
@@ -741,8 +767,8 @@ See `defclass' for more information."
741 ;; prime number length, and we also need to make our vector small 767 ;; prime number length, and we also need to make our vector small
742 ;; to save space, and also optimal for the number of items we have. 768 ;; to save space, and also optimal for the number of items we have.
743 (let* ((cnt 0) 769 (let* ((cnt 0)
744 (pubsyms (aref newc class-public-a)) 770 (pubsyms (eieio--class-public-a newc))
745 (prots (aref newc class-protection)) 771 (prots (eieio--class-protection newc))
746 (l (length pubsyms)) 772 (l (length pubsyms))
747 (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 773 (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47
748 53 59 61 67 71 73 79 83 89 97 101 ))) 774 53 59 61 67 71 73 79 83 89 97 101 )))
@@ -758,7 +784,7 @@ See `defclass' for more information."
758 (if (car prots) (put newsym 'protection (car prots))) 784 (if (car prots) (put newsym 'protection (car prots)))
759 (setq pubsyms (cdr pubsyms) 785 (setq pubsyms (cdr pubsyms)
760 prots (cdr prots))) 786 prots (cdr prots)))
761 (aset newc class-symbol-obarray oa) 787 (setf (eieio--class-symbol-obarray newc) oa)
762 ) 788 )
763 789
764 ;; Create the constructor function 790 ;; Create the constructor function
@@ -790,7 +816,7 @@ See `defclass' for more information."
790 buffer-file-name)) 816 buffer-file-name))
791 loc) 817 loc)
792 (when fname 818 (when fname
793 (when (string-match "\\.elc$" fname) 819 (when (string-match "\\.elc\\'" fname)
794 (setq fname (substring fname 0 (1- (length fname))))) 820 (setq fname (substring fname 0 (1- (length fname)))))
795 (put cname 'class-location fname))) 821 (put cname 'class-location fname)))
796 822
@@ -802,23 +828,23 @@ See `defclass' for more information."
802 (setq options (cons :custom-groups (cons g options))))) 828 (setq options (cons :custom-groups (cons g options)))))
803 829
804 ;; Set up the options we have collected. 830 ;; Set up the options we have collected.
805 (aset newc class-options options) 831 (setf (eieio--class-options newc) options)
806 832
807 ;; if this is a superclass, clear out parent (which was set to the 833 ;; if this is a superclass, clear out parent (which was set to the
808 ;; default superclass eieio-default-superclass) 834 ;; default superclass eieio-default-superclass)
809 (if clearparent (aset newc class-parent nil)) 835 (if clearparent (setf (eieio--class-parent newc) nil))
810 836
811 ;; Create the cached default object. 837 ;; Create the cached default object.
812 (let ((cache (make-vector (+ (length (aref newc class-public-a)) 838 (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3)
813 3) nil))) 839 nil)))
814 (aset cache 0 'object) 840 (aset cache 0 'object)
815 (aset cache object-class cname) 841 (setf (eieio--object-class cache) cname)
816 (aset cache object-name 'default-cache-object) 842 (setf (eieio--object-name cache) 'default-cache-object)
817 (let ((eieio-skip-typecheck t)) 843 (let ((eieio-skip-typecheck t))
818 ;; All type-checking has been done to our satisfaction 844 ;; All type-checking has been done to our satisfaction
819 ;; before this call. Don't waste our time in this call.. 845 ;; before this call. Don't waste our time in this call..
820 (eieio-set-defaults cache t)) 846 (eieio-set-defaults cache t))
821 (aset newc class-default-object-cache cache)) 847 (setf (eieio--class-default-object-cache newc) cache))
822 848
823 ;; Return our new class object 849 ;; Return our new class object
824 ;; newc 850 ;; newc
@@ -855,7 +881,7 @@ if default value is nil."
855 881
856 ;; To prevent override information w/out specification of storage, 882 ;; To prevent override information w/out specification of storage,
857 ;; we need to do this little hack. 883 ;; we need to do this little hack.
858 (if (member a (aref newc class-class-allocation-a)) (setq alloc ':class)) 884 (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class))
859 885
860 (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) 886 (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance)))
861 ;; In this case, we modify the INSTANCE version of a given slot. 887 ;; In this case, we modify the INSTANCE version of a given slot.
@@ -863,31 +889,31 @@ if default value is nil."
863 (progn 889 (progn
864 890
865 ;; Only add this element if it is so-far unique 891 ;; Only add this element if it is so-far unique
866 (if (not (member a (aref newc class-public-a))) 892 (if (not (member a (eieio--class-public-a newc)))
867 (progn 893 (progn
868 (eieio-perform-slot-validation-for-default a type d skipnil) 894 (eieio-perform-slot-validation-for-default a type d skipnil)
869 (aset newc class-public-a (cons a (aref newc class-public-a))) 895 (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc)))
870 (aset newc class-public-d (cons d (aref newc class-public-d))) 896 (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc)))
871 (aset newc class-public-doc (cons doc (aref newc class-public-doc))) 897 (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc)))
872 (aset newc class-public-type (cons type (aref newc class-public-type))) 898 (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc)))
873 (aset newc class-public-custom (cons cust (aref newc class-public-custom))) 899 (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc)))
874 (aset newc class-public-custom-label (cons label (aref newc class-public-custom-label))) 900 (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc)))
875 (aset newc class-public-custom-group (cons custg (aref newc class-public-custom-group))) 901 (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc)))
876 (aset newc class-public-printer (cons print (aref newc class-public-printer))) 902 (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc)))
877 (aset newc class-protection (cons prot (aref newc class-protection))) 903 (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc)))
878 (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples))) 904 (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc)))
879 ) 905 )
880 ;; When defaultoverride is true, we are usually adding new local 906 ;; When defaultoverride is true, we are usually adding new local
881 ;; attributes which must override the default value of any slot 907 ;; attributes which must override the default value of any slot
882 ;; passed in by one of the parent classes. 908 ;; passed in by one of the parent classes.
883 (when defaultoverride 909 (when defaultoverride
884 ;; There is a match, and we must override the old value. 910 ;; There is a match, and we must override the old value.
885 (let* ((ca (aref newc class-public-a)) 911 (let* ((ca (eieio--class-public-a newc))
886 (np (member a ca)) 912 (np (member a ca))
887 (num (- (length ca) (length np))) 913 (num (- (length ca) (length np)))
888 (dp (if np (nthcdr num (aref newc class-public-d)) 914 (dp (if np (nthcdr num (eieio--class-public-d newc))
889 nil)) 915 nil))
890 (tp (if np (nth num (aref newc class-public-type)))) 916 (tp (if np (nth num (eieio--class-public-type newc))))
891 ) 917 )
892 (if (not np) 918 (if (not np)
893 (error "EIEIO internal error overriding default value for %s" 919 (error "EIEIO internal error overriding default value for %s"
@@ -904,7 +930,7 @@ if default value is nil."
904 (setcar dp d)) 930 (setcar dp d))
905 ;; If we have a new initarg, check for it. 931 ;; If we have a new initarg, check for it.
906 (when init 932 (when init
907 (let* ((inits (aref newc class-initarg-tuples)) 933 (let* ((inits (eieio--class-initarg-tuples newc))
908 (inita (rassq a inits))) 934 (inita (rassq a inits)))
909 ;; Replace the CAR of the associate INITA. 935 ;; Replace the CAR of the associate INITA.
910 ;;(message "Initarg: %S replace %s" inita init) 936 ;;(message "Initarg: %S replace %s" inita init)
@@ -920,7 +946,7 @@ if default value is nil."
920 ;; EML - We used to have (if prot... here, 946 ;; EML - We used to have (if prot... here,
921 ;; but a prot of 'nil means public. 947 ;; but a prot of 'nil means public.
922 ;; 948 ;;
923 (let ((super-prot (nth num (aref newc class-protection))) 949 (let ((super-prot (nth num (eieio--class-protection newc)))
924 ) 950 )
925 (if (not (eq prot super-prot)) 951 (if (not (eq prot super-prot))
926 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" 952 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
@@ -932,7 +958,7 @@ if default value is nil."
932 ;; groups and new ones. 958 ;; groups and new ones.
933 (when custg 959 (when custg
934 (let* ((groups 960 (let* ((groups
935 (nthcdr num (aref newc class-public-custom-group))) 961 (nthcdr num (eieio--class-public-custom-group newc)))
936 (list1 (car groups)) 962 (list1 (car groups))
937 (list2 (if (listp custg) custg (list custg)))) 963 (list2 (if (listp custg) custg (list custg))))
938 (if (< (length list1) (length list2)) 964 (if (< (length list1) (length list2))
@@ -947,20 +973,20 @@ if default value is nil."
947 ;; set, simply replaces the old one. 973 ;; set, simply replaces the old one.
948 (when cust 974 (when cust
949 ;; (message "Custom type redefined to %s" cust) 975 ;; (message "Custom type redefined to %s" cust)
950 (setcar (nthcdr num (aref newc class-public-custom)) cust)) 976 (setcar (nthcdr num (eieio--class-public-custom newc)) cust))
951 977
952 ;; If a new label is specified, it simply replaces 978 ;; If a new label is specified, it simply replaces
953 ;; the old one. 979 ;; the old one.
954 (when label 980 (when label
955 ;; (message "Custom label redefined to %s" label) 981 ;; (message "Custom label redefined to %s" label)
956 (setcar (nthcdr num (aref newc class-public-custom-label)) label)) 982 (setcar (nthcdr num (eieio--class-public-custom-label newc)) label))
957 ;; End PLN 983 ;; End PLN
958 984
959 ;; PLN Sat Jun 30 17:24:42 2007 : when a new 985 ;; PLN Sat Jun 30 17:24:42 2007 : when a new
960 ;; doc is specified, simply replaces the old one. 986 ;; doc is specified, simply replaces the old one.
961 (when doc 987 (when doc
962 ;;(message "Documentation redefined to %s" doc) 988 ;;(message "Documentation redefined to %s" doc)
963 (setcar (nthcdr num (aref newc class-public-doc)) 989 (setcar (nthcdr num (eieio--class-public-doc newc))
964 doc)) 990 doc))
965 ;; End PLN 991 ;; End PLN
966 992
@@ -968,38 +994,38 @@ if default value is nil."
968 ;; the old one. 994 ;; the old one.
969 (when print 995 (when print
970 ;; (message "printer redefined to %s" print) 996 ;; (message "printer redefined to %s" print)
971 (setcar (nthcdr num (aref newc class-public-printer)) print)) 997 (setcar (nthcdr num (eieio--class-public-printer newc)) print))
972 998
973 ))) 999 )))
974 )) 1000 ))
975 1001
976 ;; CLASS ALLOCATED SLOTS 1002 ;; CLASS ALLOCATED SLOTS
977 (let ((value (eieio-default-eval-maybe d))) 1003 (let ((value (eieio-default-eval-maybe d)))
978 (if (not (member a (aref newc class-class-allocation-a))) 1004 (if (not (member a (eieio--class-class-allocation-a newc)))
979 (progn 1005 (progn
980 (eieio-perform-slot-validation-for-default a type value skipnil) 1006 (eieio-perform-slot-validation-for-default a type value skipnil)
981 ;; Here we have found a :class version of a slot. This 1007 ;; Here we have found a :class version of a slot. This
982 ;; requires a very different approach. 1008 ;; requires a very different approach.
983 (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a))) 1009 (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc)))
984 (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc))) 1010 (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc)))
985 (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type))) 1011 (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc)))
986 (aset newc class-class-allocation-custom (cons cust (aref newc class-class-allocation-custom))) 1012 (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc)))
987 (aset newc class-class-allocation-custom-label (cons label (aref newc class-class-allocation-custom-label))) 1013 (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc)))
988 (aset newc class-class-allocation-custom-group (cons custg (aref newc class-class-allocation-custom-group))) 1014 (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc)))
989 (aset newc class-class-allocation-protection (cons prot (aref newc class-class-allocation-protection))) 1015 (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc)))
990 ;; Default value is stored in the 'values section, since new objects 1016 ;; Default value is stored in the 'values section, since new objects
991 ;; can't initialize from this element. 1017 ;; can't initialize from this element.
992 (aset newc class-class-allocation-values (cons value (aref newc class-class-allocation-values)))) 1018 (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc))))
993 (when defaultoverride 1019 (when defaultoverride
994 ;; There is a match, and we must override the old value. 1020 ;; There is a match, and we must override the old value.
995 (let* ((ca (aref newc class-class-allocation-a)) 1021 (let* ((ca (eieio--class-class-allocation-a newc))
996 (np (member a ca)) 1022 (np (member a ca))
997 (num (- (length ca) (length np))) 1023 (num (- (length ca) (length np)))
998 (dp (if np 1024 (dp (if np
999 (nthcdr num 1025 (nthcdr num
1000 (aref newc class-class-allocation-values)) 1026 (eieio--class-class-allocation-values newc))
1001 nil)) 1027 nil))
1002 (tp (if np (nth num (aref newc class-class-allocation-type)) 1028 (tp (if np (nth num (eieio--class-class-allocation-type newc))
1003 nil))) 1029 nil)))
1004 (if (not np) 1030 (if (not np)
1005 (error "EIEIO internal error overriding default value for %s" 1031 (error "EIEIO internal error overriding default value for %s"
@@ -1023,7 +1049,7 @@ if default value is nil."
1023 ;; I wonder if a more flexible schedule might be 1049 ;; I wonder if a more flexible schedule might be
1024 ;; implemented. 1050 ;; implemented.
1025 (let ((super-prot 1051 (let ((super-prot
1026 (car (nthcdr num (aref newc class-class-allocation-protection))))) 1052 (car (nthcdr num (eieio--class-class-allocation-protection newc)))))
1027 (if (not (eq prot super-prot)) 1053 (if (not (eq prot super-prot))
1028 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" 1054 (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'"
1029 prot super-prot a))) 1055 prot super-prot a)))
@@ -1031,7 +1057,7 @@ if default value is nil."
1031 ;; and new ones. 1057 ;; and new ones.
1032 (when custg 1058 (when custg
1033 (let* ((groups 1059 (let* ((groups
1034 (nthcdr num (aref newc class-class-allocation-custom-group))) 1060 (nthcdr num (eieio--class-class-allocation-custom-group newc)))
1035 (list1 (car groups)) 1061 (list1 (car groups))
1036 (list2 (if (listp custg) custg (list custg)))) 1062 (list2 (if (listp custg) custg (list custg))))
1037 (if (< (length list1) (length list2)) 1063 (if (< (length list1) (length list2))
@@ -1045,7 +1071,7 @@ if default value is nil."
1045 ;; doc is specified, simply replaces the old one. 1071 ;; doc is specified, simply replaces the old one.
1046 (when doc 1072 (when doc
1047 ;;(message "Documentation redefined to %s" doc) 1073 ;;(message "Documentation redefined to %s" doc)
1048 (setcar (nthcdr num (aref newc class-class-allocation-doc)) 1074 (setcar (nthcdr num (eieio--class-class-allocation-doc newc))
1049 doc)) 1075 doc))
1050 ;; End PLN 1076 ;; End PLN
1051 1077
@@ -1053,7 +1079,7 @@ if default value is nil."
1053 ;; the old one. 1079 ;; the old one.
1054 (when print 1080 (when print
1055 ;; (message "printer redefined to %s" print) 1081 ;; (message "printer redefined to %s" print)
1056 (setcar (nthcdr num (aref newc class-class-allocation-printer)) print)) 1082 (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print))
1057 1083
1058 )) 1084 ))
1059 )) 1085 ))
@@ -1063,22 +1089,22 @@ if default value is nil."
1063 "Copy into NEWC the slots of PARENTS. 1089 "Copy into NEWC the slots of PARENTS.
1064Follow the rules of not overwriting early parents when applying to 1090Follow the rules of not overwriting early parents when applying to
1065the new child class." 1091the new child class."
1066 (let ((ps (aref newc class-parent)) 1092 (let ((ps (eieio--class-parent newc))
1067 (sn (class-option-assoc (aref newc class-options) 1093 (sn (class-option-assoc (eieio--class-options newc)
1068 ':allow-nil-initform))) 1094 ':allow-nil-initform)))
1069 (while ps 1095 (while ps
1070 ;; First, duplicate all the slots of the parent. 1096 ;; First, duplicate all the slots of the parent.
1071 (let ((pcv (class-v (car ps)))) 1097 (let ((pcv (class-v (car ps))))
1072 (let ((pa (aref pcv class-public-a)) 1098 (let ((pa (eieio--class-public-a pcv))
1073 (pd (aref pcv class-public-d)) 1099 (pd (eieio--class-public-d pcv))
1074 (pdoc (aref pcv class-public-doc)) 1100 (pdoc (eieio--class-public-doc pcv))
1075 (ptype (aref pcv class-public-type)) 1101 (ptype (eieio--class-public-type pcv))
1076 (pcust (aref pcv class-public-custom)) 1102 (pcust (eieio--class-public-custom pcv))
1077 (plabel (aref pcv class-public-custom-label)) 1103 (plabel (eieio--class-public-custom-label pcv))
1078 (pcustg (aref pcv class-public-custom-group)) 1104 (pcustg (eieio--class-public-custom-group pcv))
1079 (printer (aref pcv class-public-printer)) 1105 (printer (eieio--class-public-printer pcv))
1080 (pprot (aref pcv class-protection)) 1106 (pprot (eieio--class-protection pcv))
1081 (pinit (aref pcv class-initarg-tuples)) 1107 (pinit (eieio--class-initarg-tuples pcv))
1082 (i 0)) 1108 (i 0))
1083 (while pa 1109 (while pa
1084 (eieio-add-new-slot newc 1110 (eieio-add-new-slot newc
@@ -1099,15 +1125,15 @@ the new child class."
1099 pinit (cdr pinit)) 1125 pinit (cdr pinit))
1100 )) ;; while/let 1126 )) ;; while/let
1101 ;; Now duplicate all the class alloc slots. 1127 ;; Now duplicate all the class alloc slots.
1102 (let ((pa (aref pcv class-class-allocation-a)) 1128 (let ((pa (eieio--class-class-allocation-a pcv))
1103 (pdoc (aref pcv class-class-allocation-doc)) 1129 (pdoc (eieio--class-class-allocation-doc pcv))
1104 (ptype (aref pcv class-class-allocation-type)) 1130 (ptype (eieio--class-class-allocation-type pcv))
1105 (pcust (aref pcv class-class-allocation-custom)) 1131 (pcust (eieio--class-class-allocation-custom pcv))
1106 (plabel (aref pcv class-class-allocation-custom-label)) 1132 (plabel (eieio--class-class-allocation-custom-label pcv))
1107 (pcustg (aref pcv class-class-allocation-custom-group)) 1133 (pcustg (eieio--class-class-allocation-custom-group pcv))
1108 (printer (aref pcv class-class-allocation-printer)) 1134 (printer (eieio--class-class-allocation-printer pcv))
1109 (pprot (aref pcv class-class-allocation-protection)) 1135 (pprot (eieio--class-class-allocation-protection pcv))
1110 (pval (aref pcv class-class-allocation-values)) 1136 (pval (eieio--class-class-allocation-values pcv))
1111 (i 0)) 1137 (i 0))
1112 (while pa 1138 (while pa
1113 (eieio-add-new-slot newc 1139 (eieio-add-new-slot newc
@@ -1252,7 +1278,7 @@ IMPL is the symbol holding the method implementation."
1252 ;; We do have an object. Make sure it is the right type. 1278 ;; We do have an object. Make sure it is the right type.
1253 (if ,(if (eq class eieio-default-superclass) 1279 (if ,(if (eq class eieio-default-superclass)
1254 nil ; default superclass means just an obj. Already asked. 1280 nil ; default superclass means just an obj. Already asked.
1255 `(not (child-of-class-p (aref (car local-args) object-class) 1281 `(not (child-of-class-p (eieio--object-class (car local-args))
1256 ',class))) 1282 ',class)))
1257 1283
1258 ;; If not the right kind of object, call no applicable 1284 ;; If not the right kind of object, call no applicable
@@ -1335,27 +1361,20 @@ Summary:
1335(defun eieio--defmethod (method kind argclass code) 1361(defun eieio--defmethod (method kind argclass code)
1336 "Work part of the `defmethod' macro defining METHOD with ARGS." 1362 "Work part of the `defmethod' macro defining METHOD with ARGS."
1337 (let ((key 1363 (let ((key
1338 ;; find optional keys 1364 ;; Find optional keys.
1339 (cond ((or (eq ':BEFORE kind) 1365 (cond ((memq kind '(:BEFORE :before)) method-before)
1340 (eq ':before kind)) 1366 ((memq kind '(:AFTER :after)) method-after)
1341 method-before) 1367 ((memq kind '(:STATIC :static)) method-static)
1342 ((or (eq ':AFTER kind) 1368 ((memq kind '(:PRIMARY :primary nil)) method-primary)
1343 (eq ':after kind)) 1369 ;; Primary key.
1344 method-after) 1370 ;; (t method-primary)
1345 ((or (eq ':PRIMARY kind) 1371 (t (error "Unknown method kind %S" kind)))))
1346 (eq ':primary kind))
1347 method-primary)
1348 ((or (eq ':STATIC kind)
1349 (eq ':static kind))
1350 method-static)
1351 ;; Primary key
1352 (t method-primary))))
1353 ;; Make sure there is a generic (when called from defclass). 1372 ;; Make sure there is a generic (when called from defclass).
1354 (eieio--defalias 1373 (eieio--defalias
1355 method (eieio--defgeneric-init-form 1374 method (eieio--defgeneric-init-form
1356 method (or (documentation code) 1375 method (or (documentation code)
1357 (format "Generically created method `%s'." method)))) 1376 (format "Generically created method `%s'." method))))
1358 ;; create symbol for property to bind to. If the first arg is of 1377 ;; Create symbol for property to bind to. If the first arg is of
1359 ;; the form (varname vartype) and `vartype' is a class, then 1378 ;; the form (varname vartype) and `vartype' is a class, then
1360 ;; that class will be the type symbol. If not, then it will fall 1379 ;; that class will be the type symbol. If not, then it will fall
1361 ;; under the type `primary' which is a non-specific calling of the 1380 ;; under the type `primary' which is a non-specific calling of the
@@ -1364,11 +1383,9 @@ Summary:
1364 (if (not (class-p argclass)) 1383 (if (not (class-p argclass))
1365 (error "Unknown class type %s in method parameters" 1384 (error "Unknown class type %s in method parameters"
1366 argclass)) 1385 argclass))
1367 (if (= key -1) 1386 ;; Generics are higher.
1368 (signal 'wrong-type-argument (list :static 'non-class-arg)))
1369 ;; generics are higher
1370 (setq key (eieio-specialized-key-to-generic-key key))) 1387 (setq key (eieio-specialized-key-to-generic-key key)))
1371 ;; Put this lambda into the symbol so we can find it 1388 ;; Put this lambda into the symbol so we can find it.
1372 (eieiomt-add method code key argclass) 1389 (eieiomt-add method code key argclass)
1373 ) 1390 )
1374 1391
@@ -1449,7 +1466,7 @@ an error."
1449 nil 1466 nil
1450 ;; Trim off object IDX junk added in for the object index. 1467 ;; Trim off object IDX junk added in for the object index.
1451 (setq slot-idx (- slot-idx 3)) 1468 (setq slot-idx (- slot-idx 3))
1452 (let ((st (aref (aref (class-v class) class-public-type) slot-idx))) 1469 (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx)))
1453 (if (not (eieio-perform-slot-validation st value)) 1470 (if (not (eieio-perform-slot-validation st value))
1454 (signal 'invalid-slot-type (list class slot st value)))))) 1471 (signal 'invalid-slot-type (list class slot st value))))))
1455 1472
@@ -1460,7 +1477,7 @@ SLOT is the slot that is being checked, and is only used when throwing
1460an error." 1477an error."
1461 (if eieio-skip-typecheck 1478 (if eieio-skip-typecheck
1462 nil 1479 nil
1463 (let ((st (aref (aref (class-v class) class-class-allocation-type) 1480 (let ((st (aref (eieio--class-class-allocation-type (class-v class))
1464 slot-idx))) 1481 slot-idx)))
1465 (if (not (eieio-perform-slot-validation st value)) 1482 (if (not (eieio-perform-slot-validation st value))
1466 (signal 'invalid-slot-type (list class slot st value)))))) 1483 (signal 'invalid-slot-type (list class slot st value))))))
@@ -1471,7 +1488,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending
1471slot. If the slot is ok, return VALUE. 1488slot. If the slot is ok, return VALUE.
1472Argument FN is the function calling this verifier." 1489Argument FN is the function calling this verifier."
1473 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) 1490 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
1474 (slot-unbound instance (object-class instance) slotname fn) 1491 (slot-unbound instance (eieio-object-class instance) slotname fn)
1475 value)) 1492 value))
1476 1493
1477;;; Get/Set slots in an object. 1494;;; Get/Set slots in an object.
@@ -1484,27 +1501,24 @@ created by the :initarg tag."
1484 1501
1485(defun eieio-oref (obj slot) 1502(defun eieio-oref (obj slot)
1486 "Return the value in OBJ at SLOT in the object vector." 1503 "Return the value in OBJ at SLOT in the object vector."
1487 (if (not (or (eieio-object-p obj) (class-p obj))) 1504 (eieio--check-type (or eieio-object-p class-p) obj)
1488 (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj))) 1505 (eieio--check-type symbolp slot)
1489 (if (not (symbolp slot))
1490 (signal 'wrong-type-argument (list 'symbolp slot)))
1491 (if (class-p obj) (eieio-class-un-autoload obj)) 1506 (if (class-p obj) (eieio-class-un-autoload obj))
1492 (let* ((class (if (class-p obj) obj (aref obj object-class))) 1507 (let* ((class (if (class-p obj) obj (eieio--object-class obj)))
1493 (c (eieio-slot-name-index class obj slot))) 1508 (c (eieio-slot-name-index class obj slot)))
1494 (if (not c) 1509 (if (not c)
1495 ;; It might be missing because it is a :class allocated slot. 1510 ;; It might be missing because it is a :class allocated slot.
1496 ;; Let's check that info out. 1511 ;; Let's check that info out.
1497 (if (setq c (eieio-class-slot-name-index class slot)) 1512 (if (setq c (eieio-class-slot-name-index class slot))
1498 ;; Oref that slot. 1513 ;; Oref that slot.
1499 (aref (aref (class-v class) class-class-allocation-values) c) 1514 (aref (eieio--class-class-allocation-values (class-v class)) c)
1500 ;; The slot-missing method is a cool way of allowing an object author 1515 ;; The slot-missing method is a cool way of allowing an object author
1501 ;; to intercept missing slot definitions. Since it is also the LAST 1516 ;; to intercept missing slot definitions. Since it is also the LAST
1502 ;; thing called in this fn, its return value would be retrieved. 1517 ;; thing called in this fn, its return value would be retrieved.
1503 (slot-missing obj slot 'oref) 1518 (slot-missing obj slot 'oref)
1504 ;;(signal 'invalid-slot-name (list (object-name obj) slot)) 1519 ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot))
1505 ) 1520 )
1506 (if (not (eieio-object-p obj)) 1521 (eieio--check-type eieio-object-p obj)
1507 (signal 'wrong-type-argument (list 'eieio-object-p obj)))
1508 (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) 1522 (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
1509 1523
1510(defalias 'slot-value 'eieio-oref) 1524(defalias 'slot-value 'eieio-oref)
@@ -1520,9 +1534,9 @@ tag in the `defclass' call."
1520(defun eieio-oref-default (obj slot) 1534(defun eieio-oref-default (obj slot)
1521 "Do the work for the macro `oref-default' with similar parameters. 1535 "Do the work for the macro `oref-default' with similar parameters.
1522Fills in OBJ's SLOT with its default value." 1536Fills in OBJ's SLOT with its default value."
1523 (if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1537 (eieio--check-type (or eieio-object-p class-p) obj)
1524 (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) 1538 (eieio--check-type symbolp slot)
1525 (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj)) 1539 (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj))
1526 (c (eieio-slot-name-index cl obj slot))) 1540 (c (eieio-slot-name-index cl obj slot)))
1527 (if (not c) 1541 (if (not c)
1528 ;; It might be missing because it is a :class allocated slot. 1542 ;; It might be missing because it is a :class allocated slot.
@@ -1530,13 +1544,13 @@ Fills in OBJ's SLOT with its default value."
1530 (if (setq c 1544 (if (setq c
1531 (eieio-class-slot-name-index cl slot)) 1545 (eieio-class-slot-name-index cl slot))
1532 ;; Oref that slot. 1546 ;; Oref that slot.
1533 (aref (aref (class-v cl) class-class-allocation-values) 1547 (aref (eieio--class-class-allocation-values (class-v cl))
1534 c) 1548 c)
1535 (slot-missing obj slot 'oref-default) 1549 (slot-missing obj slot 'oref-default)
1536 ;;(signal 'invalid-slot-name (list (class-name cl) slot)) 1550 ;;(signal 'invalid-slot-name (list (class-name cl) slot))
1537 ) 1551 )
1538 (eieio-barf-if-slot-unbound 1552 (eieio-barf-if-slot-unbound
1539 (let ((val (nth (- c 3) (aref (class-v cl) class-public-d)))) 1553 (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl)))))
1540 (eieio-default-eval-maybe val)) 1554 (eieio-default-eval-maybe val))
1541 obj cl 'oref-default)))) 1555 obj cl 'oref-default))))
1542 1556
@@ -1590,62 +1604,78 @@ variable name of the same name as the slot."
1590;;; Simple generators, and query functions. None of these would do 1604;;; Simple generators, and query functions. None of these would do
1591;; well embedded into an object. 1605;; well embedded into an object.
1592;; 1606;;
1593(defmacro object-class-fast (obj) "Return the class struct defining OBJ with no check." 1607(define-obsolete-function-alias
1594 `(aref ,obj object-class)) 1608 'object-class-fast #'eieio--object-class "24.4")
1595 1609
1596(defun class-name (class) "Return a Lisp like symbol name for CLASS." 1610(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS."
1597 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1611 (eieio--check-type class-p class)
1598 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, 1612 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol,
1599 ;; and I wanted a string. Arg! 1613 ;; and I wanted a string. Arg!
1600 (format "#<class %s>" (symbol-name class))) 1614 (format "#<class %s>" (symbol-name class)))
1615(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
1601 1616
1602(defun object-name (obj &optional extra) 1617(defun eieio-object-name (obj &optional extra)
1603 "Return a Lisp like symbol string for object OBJ. 1618 "Return a Lisp like symbol string for object OBJ.
1604If EXTRA, include that in the string returned to represent the symbol." 1619If EXTRA, include that in the string returned to represent the symbol."
1605 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1620 (eieio--check-type eieio-object-p obj)
1606 (format "#<%s %s%s>" (symbol-name (object-class-fast obj)) 1621 (format "#<%s %s%s>" (symbol-name (eieio--object-class obj))
1607 (aref obj object-name) (or extra ""))) 1622 (eieio--object-name obj) (or extra "")))
1608 1623(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
1609(defun object-name-string (obj) "Return a string which is OBJ's name." 1624
1610 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1625(defun eieio-object-name-string (obj) "Return a string which is OBJ's name."
1611 (aref obj object-name)) 1626 (eieio--check-type eieio-object-p obj)
1612 1627 (eieio--object-name obj))
1613(defun object-set-name-string (obj name) "Set the string which is OBJ's NAME." 1628(define-obsolete-function-alias
1614 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1629 'object-name-string #'eieio-object-name-string "24.4")
1615 (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name))) 1630
1616 (aset obj object-name name)) 1631(defun eieio-object-set-name-string (obj name)
1617 1632 "Set the string which is OBJ's NAME."
1618(defun object-class (obj) "Return the class struct defining OBJ." 1633 (eieio--check-type eieio-object-p obj)
1619 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1634 (eieio--check-type stringp name)
1620 (object-class-fast obj)) 1635 (setf (eieio--object-name obj) name))
1621(defalias 'class-of 'object-class) 1636(define-obsolete-function-alias
1622 1637 'object-set-name-string 'eieio-object-set-name-string "24.4")
1623(defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." 1638
1624 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1639(defun eieio-object-class (obj) "Return the class struct defining OBJ."
1625 (class-name (object-class-fast obj))) 1640 (eieio--check-type eieio-object-p obj)
1626 1641 (eieio--object-class obj))
1627(defmacro class-parents-fast (class) "Return parent classes to CLASS with no check." 1642(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
1628 `(aref (class-v ,class) class-parent)) 1643;; CLOS name, maybe?
1629 1644(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4")
1630(defun class-parents (class) 1645
1646(defun eieio-object-class-name (obj)
1647 "Return a Lisp like symbol name for OBJ's class."
1648 (eieio--check-type eieio-object-p obj)
1649 (eieio-class-name (eieio--object-class obj)))
1650(define-obsolete-function-alias
1651 'object-class-name 'eieio-object-class-name "24.4")
1652
1653(defmacro eieio-class-parents-fast (class)
1654 "Return parent classes to CLASS with no check."
1655 `(eieio--class-parent (class-v ,class)))
1656
1657(defun eieio-class-parents (class)
1631 "Return parent classes to CLASS. (overload of variable). 1658 "Return parent classes to CLASS. (overload of variable).
1632 1659
1633The CLOS function `class-direct-superclasses' is aliased to this function." 1660The CLOS function `class-direct-superclasses' is aliased to this function."
1634 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1661 (eieio--check-type class-p class)
1635 (class-parents-fast class)) 1662 (eieio-class-parents-fast class))
1663(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
1636 1664
1637(defmacro class-children-fast (class) "Return child classes to CLASS with no check." 1665(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check."
1638 `(aref (class-v ,class) class-children)) 1666 `(eieio--class-children (class-v ,class)))
1639 1667
1640(defun class-children (class) 1668(defun eieio-class-children (class)
1641"Return child classes to CLASS. 1669 "Return child classes to CLASS.
1642 1670
1643The CLOS function `class-direct-subclasses' is aliased to this function." 1671The CLOS function `class-direct-subclasses' is aliased to this function."
1644 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1672 (eieio--check-type class-p class)
1645 (class-children-fast class)) 1673 (eieio-class-children-fast class))
1674(define-obsolete-function-alias
1675 'class-children #'eieio-class-children "24.4")
1646 1676
1647(defun eieio-c3-candidate (class remaining-inputs) 1677(defun eieio-c3-candidate (class remaining-inputs)
1648 "Returns CLASS if it can go in the result now, otherwise nil" 1678 "Return CLASS if it can go in the result now, otherwise nil"
1649 ;; Ensure CLASS is not in any position but the first in any of the 1679 ;; Ensure CLASS is not in any position but the first in any of the
1650 ;; element lists of REMAINING-INPUTS. 1680 ;; element lists of REMAINING-INPUTS.
1651 (and (not (let ((found nil)) 1681 (and (not (let ((found nil))
@@ -1691,7 +1721,7 @@ If a consistent order does not exist, signal an error."
1691 1721
1692(defun eieio-class-precedence-dfs (class) 1722(defun eieio-class-precedence-dfs (class)
1693 "Return all parents of CLASS in depth-first order." 1723 "Return all parents of CLASS in depth-first order."
1694 (let* ((parents (class-parents-fast class)) 1724 (let* ((parents (eieio-class-parents-fast class))
1695 (classes (copy-sequence 1725 (classes (copy-sequence
1696 (apply #'append 1726 (apply #'append
1697 (list class) 1727 (list class)
@@ -1712,21 +1742,21 @@ If a consistent order does not exist, signal an error."
1712(defun eieio-class-precedence-bfs (class) 1742(defun eieio-class-precedence-bfs (class)
1713 "Return all parents of CLASS in breadth-first order." 1743 "Return all parents of CLASS in breadth-first order."
1714 (let ((result) 1744 (let ((result)
1715 (queue (or (class-parents-fast class) 1745 (queue (or (eieio-class-parents-fast class)
1716 '(eieio-default-superclass)))) 1746 '(eieio-default-superclass))))
1717 (while queue 1747 (while queue
1718 (let ((head (pop queue))) 1748 (let ((head (pop queue)))
1719 (unless (member head result) 1749 (unless (member head result)
1720 (push head result) 1750 (push head result)
1721 (unless (eq head 'eieio-default-superclass) 1751 (unless (eq head 'eieio-default-superclass)
1722 (setq queue (append queue (or (class-parents-fast head) 1752 (setq queue (append queue (or (eieio-class-parents-fast head)
1723 '(eieio-default-superclass)))))))) 1753 '(eieio-default-superclass))))))))
1724 (cons class (nreverse result))) 1754 (cons class (nreverse result)))
1725 ) 1755 )
1726 1756
1727(defun eieio-class-precedence-c3 (class) 1757(defun eieio-class-precedence-c3 (class)
1728 "Return all parents of CLASS in c3 order." 1758 "Return all parents of CLASS in c3 order."
1729 (let ((parents (class-parents-fast class))) 1759 (let ((parents (eieio-class-parents-fast class)))
1730 (eieio-c3-merge-lists 1760 (eieio-c3-merge-lists
1731 (list class) 1761 (list class)
1732 (append 1762 (append
@@ -1739,7 +1769,7 @@ If a consistent order does not exist, signal an error."
1739 (list parents)))) 1769 (list parents))))
1740 ) 1770 )
1741 1771
1742(defun class-precedence-list (class) 1772(defun eieio-class-precedence-list (class)
1743 "Return (transitively closed) list of parents of CLASS. 1773 "Return (transitively closed) list of parents of CLASS.
1744The order, in which the parents are returned depends on the 1774The order, in which the parents are returned depends on the
1745method invocation orders of the involved classes." 1775method invocation orders of the involved classes."
@@ -1753,52 +1783,56 @@ method invocation orders of the involved classes."
1753 (:c3 1783 (:c3
1754 (eieio-class-precedence-c3 class)))) 1784 (eieio-class-precedence-c3 class))))
1755 ) 1785 )
1786(define-obsolete-function-alias
1787 'class-precedence-list 'eieio-class-precedence-list "24.4")
1756 1788
1757;; Official CLOS functions. 1789;; Official CLOS functions.
1758(defalias 'class-direct-superclasses 'class-parents) 1790(define-obsolete-function-alias
1759(defalias 'class-direct-subclasses 'class-children) 1791 'class-direct-superclasses #'eieio-class-parents "24.4")
1760 1792(define-obsolete-function-alias
1761(defmacro class-parent-fast (class) "Return first parent class to CLASS with no check." 1793 'class-direct-subclasses #'eieio-class-children "24.4")
1762 `(car (class-parents-fast ,class)))
1763 1794
1764(defmacro class-parent (class) "Return first parent class to CLASS. (overload of variable)." 1795(defmacro eieio-class-parent (class)
1765 `(car (class-parents ,class))) 1796 "Return first parent class to CLASS. (overload of variable)."
1797 `(car (eieio-class-parents ,class)))
1798(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4")
1766 1799
1767(defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type CLASS with no error checking." 1800(defmacro same-class-fast-p (obj class)
1768 `(eq (aref ,obj object-class) ,class)) 1801 "Return t if OBJ is of class-type CLASS with no error checking."
1802 `(eq (eieio--object-class ,obj) ,class))
1769 1803
1770(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." 1804(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS."
1771 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1805 (eieio--check-type class-p class)
1772 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1806 (eieio--check-type eieio-object-p obj)
1773 (same-class-fast-p obj class)) 1807 (same-class-fast-p obj class))
1774 1808
1775(defun object-of-class-p (obj class) 1809(defun object-of-class-p (obj class)
1776 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." 1810 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
1777 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1811 (eieio--check-type eieio-object-p obj)
1778 ;; class will be checked one layer down 1812 ;; class will be checked one layer down
1779 (child-of-class-p (aref obj object-class) class)) 1813 (child-of-class-p (eieio--object-class obj) class))
1780;; Backwards compatibility 1814;; Backwards compatibility
1781(defalias 'obj-of-class-p 'object-of-class-p) 1815(defalias 'obj-of-class-p 'object-of-class-p)
1782 1816
1783(defun child-of-class-p (child class) 1817(defun child-of-class-p (child class)
1784 "Return non-nil if CHILD class is a subclass of CLASS." 1818 "Return non-nil if CHILD class is a subclass of CLASS."
1785 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1819 (eieio--check-type class-p class)
1786 (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child))) 1820 (eieio--check-type class-p child)
1787 (let ((p nil)) 1821 (let ((p nil))
1788 (while (and child (not (eq child class))) 1822 (while (and child (not (eq child class)))
1789 (setq p (append p (aref (class-v child) class-parent)) 1823 (setq p (append p (eieio--class-parent (class-v child)))
1790 child (car p) 1824 child (car p)
1791 p (cdr p))) 1825 p (cdr p)))
1792 (if child t))) 1826 (if child t)))
1793 1827
1794(defun object-slots (obj) 1828(defun object-slots (obj)
1795 "Return list of slots available in OBJ." 1829 "Return list of slots available in OBJ."
1796 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1830 (eieio--check-type eieio-object-p obj)
1797 (aref (class-v (object-class-fast obj)) class-public-a)) 1831 (eieio--class-public-a (class-v (eieio--object-class obj))))
1798 1832
1799(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." 1833(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
1800 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1834 (eieio--check-type class-p class)
1801 (let ((ia (aref (class-v class) class-initarg-tuples)) 1835 (let ((ia (eieio--class-initarg-tuples (class-v class)))
1802 (f nil)) 1836 (f nil))
1803 (while (and ia (not f)) 1837 (while (and ia (not f))
1804 (if (eq (cdr (car ia)) slot) 1838 (if (eq (cdr (car ia)) slot)
@@ -1817,25 +1851,24 @@ with in the :initarg slot. VALUE can be any Lisp object."
1817(defun eieio-oset (obj slot value) 1851(defun eieio-oset (obj slot value)
1818 "Do the work for the macro `oset'. 1852 "Do the work for the macro `oset'.
1819Fills in OBJ's SLOT with VALUE." 1853Fills in OBJ's SLOT with VALUE."
1820 (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) 1854 (eieio--check-type eieio-object-p obj)
1821 (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) 1855 (eieio--check-type symbolp slot)
1822 (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) 1856 (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot)))
1823 (if (not c) 1857 (if (not c)
1824 ;; It might be missing because it is a :class allocated slot. 1858 ;; It might be missing because it is a :class allocated slot.
1825 ;; Let's check that info out. 1859 ;; Let's check that info out.
1826 (if (setq c 1860 (if (setq c
1827 (eieio-class-slot-name-index (aref obj object-class) slot)) 1861 (eieio-class-slot-name-index (eieio--object-class obj) slot))
1828 ;; Oset that slot. 1862 ;; Oset that slot.
1829 (progn 1863 (progn
1830 (eieio-validate-class-slot-value (object-class-fast obj) c value slot) 1864 (eieio-validate-class-slot-value (eieio--object-class obj) c value slot)
1831 (aset (aref (class-v (aref obj object-class)) 1865 (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj)))
1832 class-class-allocation-values)
1833 c value)) 1866 c value))
1834 ;; See oref for comment on `slot-missing' 1867 ;; See oref for comment on `slot-missing'
1835 (slot-missing obj slot 'oset value) 1868 (slot-missing obj slot 'oset value)
1836 ;;(signal 'invalid-slot-name (list (object-name obj) slot)) 1869 ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot))
1837 ) 1870 )
1838 (eieio-validate-slot-value (object-class-fast obj) c value slot) 1871 (eieio-validate-slot-value (eieio--object-class obj) c value slot)
1839 (aset obj c value)))) 1872 (aset obj c value))))
1840 1873
1841(defmacro oset-default (class slot value) 1874(defmacro oset-default (class slot value)
@@ -1848,8 +1881,8 @@ after they are created."
1848(defun eieio-oset-default (class slot value) 1881(defun eieio-oset-default (class slot value)
1849 "Do the work for the macro `oset-default'. 1882 "Do the work for the macro `oset-default'.
1850Fills in the default value in CLASS' in SLOT with VALUE." 1883Fills in the default value in CLASS' in SLOT with VALUE."
1851 (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) 1884 (eieio--check-type class-p class)
1852 (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) 1885 (eieio--check-type symbolp slot)
1853 (let* ((scoped-class class) 1886 (let* ((scoped-class class)
1854 (c (eieio-slot-name-index class nil slot))) 1887 (c (eieio-slot-name-index class nil slot)))
1855 (if (not c) 1888 (if (not c)
@@ -1859,15 +1892,15 @@ Fills in the default value in CLASS' in SLOT with VALUE."
1859 (progn 1892 (progn
1860 ;; Oref that slot. 1893 ;; Oref that slot.
1861 (eieio-validate-class-slot-value class c value slot) 1894 (eieio-validate-class-slot-value class c value slot)
1862 (aset (aref (class-v class) class-class-allocation-values) c 1895 (aset (eieio--class-class-allocation-values (class-v class)) c
1863 value)) 1896 value))
1864 (signal 'invalid-slot-name (list (class-name class) slot))) 1897 (signal 'invalid-slot-name (list (eieio-class-name class) slot)))
1865 (eieio-validate-slot-value class c value slot) 1898 (eieio-validate-slot-value class c value slot)
1866 ;; Set this into the storage for defaults. 1899 ;; Set this into the storage for defaults.
1867 (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) 1900 (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class)))
1868 value) 1901 value)
1869 ;; Take the value, and put it into our cache object. 1902 ;; Take the value, and put it into our cache object.
1870 (eieio-oset (aref (class-v class) class-default-object-cache) 1903 (eieio-oset (eieio--class-default-object-cache (class-v class))
1871 slot value) 1904 slot value)
1872 ))) 1905 )))
1873 1906
@@ -1894,12 +1927,12 @@ OBJECT can be an instance or a class."
1894(defun slot-exists-p (object-or-class slot) 1927(defun slot-exists-p (object-or-class slot)
1895 "Return non-nil if OBJECT-OR-CLASS has SLOT." 1928 "Return non-nil if OBJECT-OR-CLASS has SLOT."
1896 (let ((cv (class-v (cond ((eieio-object-p object-or-class) 1929 (let ((cv (class-v (cond ((eieio-object-p object-or-class)
1897 (object-class object-or-class)) 1930 (eieio-object-class object-or-class))
1898 ((class-p object-or-class) 1931 ((class-p object-or-class)
1899 object-or-class)) 1932 object-or-class))
1900 ))) 1933 )))
1901 (or (memq slot (aref cv class-public-a)) 1934 (or (memq slot (eieio--class-public-a cv))
1902 (memq slot (aref cv class-class-allocation-a))) 1935 (memq slot (eieio--class-class-allocation-a cv)))
1903 )) 1936 ))
1904 1937
1905(defun find-class (symbol &optional errorp) 1938(defun find-class (symbol &optional errorp)
@@ -1919,7 +1952,7 @@ LIST is a list of objects whose slots are searched.
1919Objects in LIST do not need to have a slot named SLOT, nor does 1952Objects in LIST do not need to have a slot named SLOT, nor does
1920SLOT need to be bound. If these errors occur, those objects will 1953SLOT need to be bound. If these errors occur, those objects will
1921be ignored." 1954be ignored."
1922 (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) 1955 (eieio--check-type listp list)
1923 (while (and list (not (condition-case nil 1956 (while (and list (not (condition-case nil
1924 ;; This prevents errors for missing slots. 1957 ;; This prevents errors for missing slots.
1925 (equal key (eieio-oref (car list) slot)) 1958 (equal key (eieio-oref (car list) slot))
@@ -1931,7 +1964,7 @@ be ignored."
1931 "Return an association list with the contents of SLOT as the key element. 1964 "Return an association list with the contents of SLOT as the key element.
1932LIST must be a list of objects with SLOT in it. 1965LIST must be a list of objects with SLOT in it.
1933This is useful when you need to do completing read on an object group." 1966This is useful when you need to do completing read on an object group."
1934 (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) 1967 (eieio--check-type listp list)
1935 (let ((assoclist nil)) 1968 (let ((assoclist nil))
1936 (while list 1969 (while list
1937 (setq assoclist (cons (cons (eieio-oref (car list) slot) 1970 (setq assoclist (cons (cons (eieio-oref (car list) slot)
@@ -1945,7 +1978,7 @@ This is useful when you need to do completing read on an object group."
1945LIST must be a list of objects, but those objects do not need to have 1978LIST must be a list of objects, but those objects do not need to have
1946SLOT in it. If it does not, then that element is left out of the association 1979SLOT in it. If it does not, then that element is left out of the association
1947list." 1980list."
1948 (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) 1981 (eieio--check-type listp list)
1949 (let ((assoclist nil)) 1982 (let ((assoclist nil))
1950 (while list 1983 (while list
1951 (if (slot-exists-p (car list) slot) 1984 (if (slot-exists-p (car list) slot)
@@ -1993,14 +2026,13 @@ If SLOT is unbound, do nothing."
1993 "Return non-nil if START-CLASS is the first class to define SLOT. 2026 "Return non-nil if START-CLASS is the first class to define SLOT.
1994This is for testing if `scoped-class' is the class that defines SLOT 2027This is for testing if `scoped-class' is the class that defines SLOT
1995so that we can protect private slots." 2028so that we can protect private slots."
1996 (let ((par (class-parents start-class)) 2029 (let ((par (eieio-class-parents start-class))
1997 (ret t)) 2030 (ret t))
1998 (if (not par) 2031 (if (not par)
1999 t 2032 t
2000 (while (and par ret) 2033 (while (and par ret)
2001 (if (intern-soft (symbol-name slot) 2034 (if (intern-soft (symbol-name slot)
2002 (aref (class-v (car par)) 2035 (eieio--class-symbol-obarray (class-v (car par))))
2003 class-symbol-obarray))
2004 (setq ret nil)) 2036 (setq ret nil))
2005 (setq par (cdr par))) 2037 (setq par (cdr par)))
2006 ret))) 2038 ret)))
@@ -2015,8 +2047,7 @@ If SLOT is the value created with :initarg instead,
2015reverse-lookup that name, and recurse with the associated slot value." 2047reverse-lookup that name, and recurse with the associated slot value."
2016 ;; Removed checks to outside this call 2048 ;; Removed checks to outside this call
2017 (let* ((fsym (intern-soft (symbol-name slot) 2049 (let* ((fsym (intern-soft (symbol-name slot)
2018 (aref (class-v class) 2050 (eieio--class-symbol-obarray (class-v class))))
2019 class-symbol-obarray)))
2020 (fsi (if (symbolp fsym) (symbol-value fsym) nil))) 2051 (fsi (if (symbolp fsym) (symbol-value fsym) nil)))
2021 (if (integerp fsi) 2052 (if (integerp fsi)
2022 (cond 2053 (cond
@@ -2026,7 +2057,7 @@ reverse-lookup that name, and recurse with the associated slot value."
2026 (bound-and-true-p scoped-class) 2057 (bound-and-true-p scoped-class)
2027 (or (child-of-class-p class scoped-class) 2058 (or (child-of-class-p class scoped-class)
2028 (and (eieio-object-p obj) 2059 (and (eieio-object-p obj)
2029 (child-of-class-p class (object-class obj))))) 2060 (child-of-class-p class (eieio-object-class obj)))))
2030 (+ 3 fsi)) 2061 (+ 3 fsi))
2031 ((and (eq (get fsym 'protection) 'private) 2062 ((and (eq (get fsym 'protection) 'private)
2032 (or (and (bound-and-true-p scoped-class) 2063 (or (and (bound-and-true-p scoped-class)
@@ -2044,7 +2075,7 @@ call. If SLOT is the value created with :initarg instead,
2044reverse-lookup that name, and recurse with the associated slot value." 2075reverse-lookup that name, and recurse with the associated slot value."
2045 ;; This will happen less often, and with fewer slots. Do this the 2076 ;; This will happen less often, and with fewer slots. Do this the
2046 ;; storage cheap way. 2077 ;; storage cheap way.
2047 (let* ((a (aref (class-v class) class-class-allocation-a)) 2078 (let* ((a (eieio--class-class-allocation-a (class-v class)))
2048 (l1 (length a)) 2079 (l1 (length a))
2049 (af (memq slot a)) 2080 (af (memq slot a))
2050 (l2 (length af))) 2081 (l2 (length af)))
@@ -2099,7 +2130,7 @@ This should only be called from a generic function."
2099 (load (nth 1 (symbol-function firstarg)))) 2130 (load (nth 1 (symbol-function firstarg))))
2100 ;; Determine the class to use. 2131 ;; Determine the class to use.
2101 (cond ((eieio-object-p firstarg) 2132 (cond ((eieio-object-p firstarg)
2102 (setq mclass (object-class-fast firstarg))) 2133 (setq mclass (eieio--object-class firstarg)))
2103 ((class-p firstarg) 2134 ((class-p firstarg)
2104 (setq mclass firstarg)) 2135 (setq mclass firstarg))
2105 ) 2136 )
@@ -2236,7 +2267,7 @@ for this common case to improve performance."
2236 2267
2237 ;; Determine the class to use. 2268 ;; Determine the class to use.
2238 (cond ((eieio-object-p firstarg) 2269 (cond ((eieio-object-p firstarg)
2239 (setq mclass (object-class-fast firstarg))) 2270 (setq mclass (eieio--object-class firstarg)))
2240 ((not firstarg) 2271 ((not firstarg)
2241 (error "Method %s called on nil" method)) 2272 (error "Method %s called on nil" method))
2242 ((not (eieio-object-p firstarg)) 2273 ((not (eieio-object-p firstarg))
@@ -2303,7 +2334,7 @@ If CLASS is nil, then an empty list of methods should be returned."
2303 ;; Collect lambda expressions stored for the class and its parent 2334 ;; Collect lambda expressions stored for the class and its parent
2304 ;; classes. 2335 ;; classes.
2305 (let (lambdas) 2336 (let (lambdas)
2306 (dolist (ancestor (class-precedence-list class)) 2337 (dolist (ancestor (eieio-class-precedence-list class))
2307 ;; Lookup the form to use for the PRIMARY object for the next level 2338 ;; Lookup the form to use for the PRIMARY object for the next level
2308 (let ((tmpl (eieio-generic-form method key ancestor))) 2339 (let ((tmpl (eieio-generic-form method key ancestor)))
2309 (when (and tmpl 2340 (when (and tmpl
@@ -2447,7 +2478,7 @@ This is different from function `class-parent' as class parent returns
2447nil for superclasses. This function performs no type checking!" 2478nil for superclasses. This function performs no type checking!"
2448 ;; No type-checking because all calls are made from functions which 2479 ;; No type-checking because all calls are made from functions which
2449 ;; are safe and do checking for us. 2480 ;; are safe and do checking for us.
2450 (or (class-parents-fast class) 2481 (or (eieio-class-parents-fast class)
2451 (if (eq class 'eieio-default-superclass) 2482 (if (eq class 'eieio-default-superclass)
2452 nil 2483 nil
2453 '(eieio-default-superclass)))) 2484 '(eieio-default-superclass))))
@@ -2460,7 +2491,7 @@ nil for superclasses. This function performs no type checking!"
2460 ;; we replace the nil from above. 2491 ;; we replace the nil from above.
2461 (let ((external-symbol (intern-soft (symbol-name s)))) 2492 (let ((external-symbol (intern-soft (symbol-name s))))
2462 (catch 'done 2493 (catch 'done
2463 (dolist (ancestor (rest (class-precedence-list external-symbol))) 2494 (dolist (ancestor (rest (eieio-class-precedence-list external-symbol)))
2464 (let ((ov (intern-soft (symbol-name ancestor) 2495 (let ((ov (intern-soft (symbol-name ancestor)
2465 eieiomt-optimizing-obarray))) 2496 eieiomt-optimizing-obarray)))
2466 (when (fboundp ov) 2497 (when (fboundp ov)
@@ -2489,7 +2520,7 @@ is memorized for faster future use."
2489 (eieiomt-sym-optimize cs)))) 2520 (eieiomt-sym-optimize cs))))
2490 ;; 3) If it's bound return this one. 2521 ;; 3) If it's bound return this one.
2491 (if (fboundp cs) 2522 (if (fboundp cs)
2492 (cons cs (aref (class-v class) class-symbol)) 2523 (cons cs (eieio--class-symbol (class-v class)))
2493 ;; 4) If it's not bound then this variable knows something 2524 ;; 4) If it's not bound then this variable knows something
2494 (if (symbol-value cs) 2525 (if (symbol-value cs)
2495 (progn 2526 (progn
@@ -2499,8 +2530,7 @@ is memorized for faster future use."
2499 ;; 4.2) The optimizer should always have chosen a 2530 ;; 4.2) The optimizer should always have chosen a
2500 ;; function-symbol 2531 ;; function-symbol
2501 ;;(if (fboundp cs) 2532 ;;(if (fboundp cs)
2502 (cons cs (aref (class-v (intern (symbol-name class))) 2533 (cons cs (eieio--class-symbol (class-v (intern (symbol-name class)))))
2503 class-symbol))
2504 ;;(error "EIEIO optimizer: erratic data loss!")) 2534 ;;(error "EIEIO optimizer: erratic data loss!"))
2505 ) 2535 )
2506 ;; There never will be a funcall... 2536 ;; There never will be a funcall...
@@ -2523,9 +2553,9 @@ is memorized for faster future use."
2523If SET-ALL is non-nil, then when a default is nil, that value is 2553If SET-ALL is non-nil, then when a default is nil, that value is
2524reset. If SET-ALL is nil, the slots are only reset if the default is 2554reset. If SET-ALL is nil, the slots are only reset if the default is
2525not nil." 2555not nil."
2526 (let ((scoped-class (aref obj object-class)) 2556 (let ((scoped-class (eieio--object-class obj))
2527 (eieio-initializing-object t) 2557 (eieio-initializing-object t)
2528 (pub (aref (class-v (aref obj object-class)) class-public-a))) 2558 (pub (eieio--class-public-a (class-v (eieio--object-class obj)))))
2529 (while pub 2559 (while pub
2530 (let ((df (eieio-oref-default obj (car pub)))) 2560 (let ((df (eieio-oref-default obj (car pub))))
2531 (if (or df set-all) 2561 (if (or df set-all)
@@ -2536,7 +2566,7 @@ not nil."
2536 "For CLASS, convert INITARG to the actual attribute name. 2566 "For CLASS, convert INITARG to the actual attribute name.
2537If there is no translation, pass it in directly (so we can cheat if 2567If there is no translation, pass it in directly (so we can cheat if
2538need be... May remove that later...)" 2568need be... May remove that later...)"
2539 (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples)))) 2569 (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class)))))
2540 (if tuple 2570 (if tuple
2541 (cdr tuple) 2571 (cdr tuple)
2542 nil))) 2572 nil)))
@@ -2544,7 +2574,7 @@ need be... May remove that later...)"
2544(defun eieio-attribute-to-initarg (class attribute) 2574(defun eieio-attribute-to-initarg (class attribute)
2545 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. 2575 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
2546This is usually a symbol that starts with `:'." 2576This is usually a symbol that starts with `:'."
2547 (let ((tuple (rassoc attribute (aref (class-v class) class-initarg-tuples)))) 2577 (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class)))))
2548 (if tuple 2578 (if tuple
2549 (car tuple) 2579 (car tuple)
2550 nil))) 2580 nil)))
@@ -2632,10 +2662,9 @@ SLOTS are the initialization slots used by `shared-initialize'.
2632This static method is called when an object is constructed. 2662This static method is called when an object is constructed.
2633It allocates the vector used to represent an EIEIO object, and then 2663It allocates the vector used to represent an EIEIO object, and then
2634calls `shared-initialize' on that object." 2664calls `shared-initialize' on that object."
2635 (let* ((new-object (copy-sequence (aref (class-v class) 2665 (let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class)))))
2636 class-default-object-cache))))
2637 ;; Update the name for the newly created object. 2666 ;; Update the name for the newly created object.
2638 (aset new-object object-name newname) 2667 (setf (eieio--object-name new-object) newname)
2639 ;; Call the initialize method on the new object with the slots 2668 ;; Call the initialize method on the new object with the slots
2640 ;; that were passed down to us. 2669 ;; that were passed down to us.
2641 (initialize-instance new-object slots) 2670 (initialize-instance new-object slots)
@@ -2649,9 +2678,9 @@ Called from the constructor routine.")
2649(defmethod shared-initialize ((obj eieio-default-superclass) slots) 2678(defmethod shared-initialize ((obj eieio-default-superclass) slots)
2650 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 2679 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
2651Called from the constructor routine." 2680Called from the constructor routine."
2652 (let ((scoped-class (aref obj object-class))) 2681 (let ((scoped-class (eieio--object-class obj)))
2653 (while slots 2682 (while slots
2654 (let ((rn (eieio-initarg-to-attribute (object-class-fast obj) 2683 (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj)
2655 (car slots)))) 2684 (car slots))))
2656 (if (not rn) 2685 (if (not rn)
2657 (slot-missing obj (car slots) 'oset (car (cdr slots))) 2686 (slot-missing obj (car slots) 'oset (car (cdr slots)))
@@ -2673,9 +2702,9 @@ not taken, then new objects of your class will not have their values
2673dynamically set from SLOTS." 2702dynamically set from SLOTS."
2674 ;; First, see if any of our defaults are `lambda', and 2703 ;; First, see if any of our defaults are `lambda', and
2675 ;; re-evaluate them and apply the value to our slots. 2704 ;; re-evaluate them and apply the value to our slots.
2676 (let* ((scoped-class (class-v (aref this object-class))) 2705 (let* ((scoped-class (class-v (eieio--object-class this)))
2677 (slot (aref scoped-class class-public-a)) 2706 (slot (eieio--class-public-a scoped-class))
2678 (defaults (aref scoped-class class-public-d))) 2707 (defaults (eieio--class-public-d scoped-class)))
2679 (while slot 2708 (while slot
2680 ;; For each slot, see if we need to evaluate it. 2709 ;; For each slot, see if we need to evaluate it.
2681 ;; 2710 ;;
@@ -2705,7 +2734,7 @@ to be set.
2705 2734
2706This method is called from `oref', `oset', and other functions which 2735This method is called from `oref', `oset', and other functions which
2707directly reference slots in EIEIO objects." 2736directly reference slots in EIEIO objects."
2708 (signal 'invalid-slot-name (list (object-name object) 2737 (signal 'invalid-slot-name (list (eieio-object-name object)
2709 slot-name))) 2738 slot-name)))
2710 2739
2711(defgeneric slot-unbound (object class slot-name fn) 2740(defgeneric slot-unbound (object class slot-name fn)
@@ -2723,7 +2752,7 @@ Use `slot-boundp' to determine if a slot is bound or not.
2723 2752
2724In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but 2753In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but
2725EIEIO can only dispatch on the first argument, so the first two are swapped." 2754EIEIO can only dispatch on the first argument, so the first two are swapped."
2726 (signal 'unbound-slot (list (class-name class) (object-name object) 2755 (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object)
2727 slot-name fn))) 2756 slot-name fn)))
2728 2757
2729(defgeneric no-applicable-method (object method &rest args) 2758(defgeneric no-applicable-method (object method &rest args)
@@ -2737,7 +2766,7 @@ ARGS are the arguments that were passed to METHOD.
2737 2766
2738Implement this for a class to block this signal. The return 2767Implement this for a class to block this signal. The return
2739value becomes the return value of the original method call." 2768value becomes the return value of the original method call."
2740 (signal 'no-method-definition (list method (object-name object))) 2769 (signal 'no-method-definition (list method (eieio-object-name object)))
2741 ) 2770 )
2742 2771
2743(defgeneric no-next-method (object &rest args) 2772(defgeneric no-next-method (object &rest args)
@@ -2751,7 +2780,7 @@ ARGS are the arguments it is called by.
2751This method signals `no-next-method' by default. Override this 2780This method signals `no-next-method' by default. Override this
2752method to not throw an error, and its return value becomes the 2781method to not throw an error, and its return value becomes the
2753return value of `call-next-method'." 2782return value of `call-next-method'."
2754 (signal 'no-next-method (list (object-name object) args)) 2783 (signal 'no-next-method (list (eieio-object-name object) args))
2755 ) 2784 )
2756 2785
2757(defgeneric clone (obj &rest params) 2786(defgeneric clone (obj &rest params)
@@ -2764,7 +2793,7 @@ first and modify the returned object.")
2764(defmethod clone ((obj eieio-default-superclass) &rest params) 2793(defmethod clone ((obj eieio-default-superclass) &rest params)
2765 "Make a copy of OBJ, and then apply PARAMS." 2794 "Make a copy of OBJ, and then apply PARAMS."
2766 (let ((nobj (copy-sequence obj)) 2795 (let ((nobj (copy-sequence obj))
2767 (nm (aref obj object-name)) 2796 (nm (eieio--object-name obj))
2768 (passname (and params (stringp (car params)))) 2797 (passname (and params (stringp (car params))))
2769 (num 1)) 2798 (num 1))
2770 (if params (shared-initialize nobj (if passname (cdr params) params))) 2799 (if params (shared-initialize nobj (if passname (cdr params) params)))
@@ -2773,8 +2802,8 @@ first and modify the returned object.")
2773 (if (string-match "-\\([0-9]+\\)" nm) 2802 (if (string-match "-\\([0-9]+\\)" nm)
2774 (setq num (1+ (string-to-number (match-string 1 nm))) 2803 (setq num (1+ (string-to-number (match-string 1 nm)))
2775 nm (substring nm 0 (match-beginning 0)))) 2804 nm (substring nm 0 (match-beginning 0))))
2776 (aset nobj object-name (concat nm "-" (int-to-string num)))) 2805 (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
2777 (aset nobj object-name (car params))) 2806 (setf (eieio--object-name nobj) (car params)))
2778 nobj)) 2807 nobj))
2779 2808
2780(defgeneric destructor (this &rest params) 2809(defgeneric destructor (this &rest params)
@@ -2806,7 +2835,7 @@ Implement this function and specify STRINGS in a call to
2806`call-next-method' to provide additional summary information. 2835`call-next-method' to provide additional summary information.
2807When passing in extra strings from child classes, always remember 2836When passing in extra strings from child classes, always remember
2808to prepend a space." 2837to prepend a space."
2809 (object-name this (apply 'concat strings))) 2838 (eieio-object-name this (apply 'concat strings)))
2810 2839
2811(defvar eieio-print-depth 0 2840(defvar eieio-print-depth 0
2812 "When printing, keep track of the current indentation depth.") 2841 "When printing, keep track of the current indentation depth.")
@@ -2823,11 +2852,11 @@ object are discouraged from being written.
2823this object." 2852this object."
2824 (when comment 2853 (when comment
2825 (princ ";; Object ") 2854 (princ ";; Object ")
2826 (princ (object-name-string this)) 2855 (princ (eieio-object-name-string this))
2827 (princ "\n") 2856 (princ "\n")
2828 (princ comment) 2857 (princ comment)
2829 (princ "\n")) 2858 (princ "\n"))
2830 (let* ((cl (object-class this)) 2859 (let* ((cl (eieio-object-class this))
2831 (cv (class-v cl))) 2860 (cv (class-v cl)))
2832 ;; Now output readable lisp to recreate this object 2861 ;; Now output readable lisp to recreate this object
2833 ;; It should look like this: 2862 ;; It should look like this:
@@ -2835,14 +2864,14 @@ this object."
2835 ;; Each slot's slot is writen using its :writer. 2864 ;; Each slot's slot is writen using its :writer.
2836 (princ (make-string (* eieio-print-depth 2) ? )) 2865 (princ (make-string (* eieio-print-depth 2) ? ))
2837 (princ "(") 2866 (princ "(")
2838 (princ (symbol-name (class-constructor (object-class this)))) 2867 (princ (symbol-name (class-constructor (eieio-object-class this))))
2839 (princ " ") 2868 (princ " ")
2840 (prin1 (object-name-string this)) 2869 (prin1 (eieio-object-name-string this))
2841 (princ "\n") 2870 (princ "\n")
2842 ;; Loop over all the public slots 2871 ;; Loop over all the public slots
2843 (let ((publa (aref cv class-public-a)) 2872 (let ((publa (eieio--class-public-a cv))
2844 (publd (aref cv class-public-d)) 2873 (publd (eieio--class-public-d cv))
2845 (publp (aref cv class-public-printer)) 2874 (publp (eieio--class-public-printer cv))
2846 (eieio-print-depth (1+ eieio-print-depth))) 2875 (eieio-print-depth (1+ eieio-print-depth)))
2847 (while publa 2876 (while publa
2848 (when (slot-boundp this (car publa)) 2877 (when (slot-boundp this (car publa))
@@ -2877,7 +2906,7 @@ this object."
2877 ((consp thing) 2906 ((consp thing)
2878 (eieio-list-prin1 thing)) 2907 (eieio-list-prin1 thing))
2879 ((class-p thing) 2908 ((class-p thing)
2880 (princ (class-name thing))) 2909 (princ (eieio-class-name thing)))
2881 ((or (keywordp thing) (booleanp thing)) 2910 ((or (keywordp thing) (booleanp thing))
2882 (prin1 thing)) 2911 (prin1 thing))
2883 ((symbolp thing) 2912 ((symbolp thing)
@@ -2921,34 +2950,30 @@ of `eq'."
2921 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) 2950 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
2922 ;; find optional keys 2951 ;; find optional keys
2923 (setq key 2952 (setq key
2924 (cond ((or (eq ':BEFORE (car args)) 2953 (cond ((memq (car args) '(:BEFORE :before))
2925 (eq ':before (car args)))
2926 (setq args (cdr args)) 2954 (setq args (cdr args))
2927 method-before) 2955 method-before)
2928 ((or (eq ':AFTER (car args)) 2956 ((memq (car args) '(:AFTER :after))
2929 (eq ':after (car args)))
2930 (setq args (cdr args)) 2957 (setq args (cdr args))
2931 method-after) 2958 method-after)
2932 ((or (eq ':PRIMARY (car args)) 2959 ((memq (car args) '(:STATIC :static))
2933 (eq ':primary (car args)))
2934 (setq args (cdr args))
2935 method-primary)
2936 ((or (eq ':STATIC (car args))
2937 (eq ':static (car args)))
2938 (setq args (cdr args)) 2960 (setq args (cdr args))
2939 method-static) 2961 method-static)
2940 ;; Primary key 2962 ((memq (car args) '(:PRIMARY :primary))
2963 (setq args (cdr args))
2964 method-primary)
2965 ;; Primary key.
2941 (t method-primary))) 2966 (t method-primary)))
2942 ;; get body, and fix contents of args to be the arguments of the fn. 2967 ;; Get body, and fix contents of args to be the arguments of the fn.
2943 (setq body (cdr args) 2968 (setq body (cdr args)
2944 args (car args)) 2969 args (car args))
2945 (setq loopa args) 2970 (setq loopa args)
2946 ;; Create a fixed version of the arguments 2971 ;; Create a fixed version of the arguments.
2947 (while loopa 2972 (while loopa
2948 (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) 2973 (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
2949 argfix)) 2974 argfix))
2950 (setq loopa (cdr loopa))) 2975 (setq loopa (cdr loopa)))
2951 ;; make sure there is a generic 2976 ;; Make sure there is a generic.
2952 (eieio-defgeneric 2977 (eieio-defgeneric
2953 method 2978 method
2954 (if (stringp (car body)) 2979 (if (stringp (car body))
@@ -2965,11 +2990,9 @@ of `eq'."
2965 (if (not (class-p argclass)) 2990 (if (not (class-p argclass))
2966 (error "Unknown class type %s in method parameters" 2991 (error "Unknown class type %s in method parameters"
2967 (nth 1 firstarg)))) 2992 (nth 1 firstarg))))
2968 (if (= key -1) 2993 ;; Generics are higher.
2969 (signal 'wrong-type-argument (list :static 'non-class-arg)))
2970 ;; generics are higher
2971 (setq key (eieio-specialized-key-to-generic-key key))) 2994 (setq key (eieio-specialized-key-to-generic-key key)))
2972 ;; Put this lambda into the symbol so we can find it 2995 ;; Put this lambda into the symbol so we can find it.
2973 (if (byte-code-function-p (car-safe body)) 2996 (if (byte-code-function-p (car-safe body))
2974 (eieiomt-add method (car-safe body) key argclass) 2997 (eieiomt-add method (car-safe body) key argclass)
2975 (eieiomt-add method (append (list 'lambda (reverse argfix)) body) 2998 (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
@@ -3019,7 +3042,7 @@ of `eq'."
3019 "Display EIEIO OBJECT in fancy format. 3042 "Display EIEIO OBJECT in fancy format.
3020Overrides the edebug default. 3043Overrides the edebug default.
3021Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." 3044Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
3022 (cond ((class-p object) (class-name object)) 3045 (cond ((class-p object) (eieio-class-name object))
3023 ((eieio-object-p object) (object-print object)) 3046 ((eieio-object-p object) (object-print object))
3024 ((and (listp object) (or (class-p (car object)) 3047 ((and (listp object) (or (class-p (car object))
3025 (eieio-object-p (car object)))) 3048 (eieio-object-p (car object))))
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-23 22:31:53 +0000