aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2015-01-08 16:03:04 -0500
committerStefan Monnier2015-01-08 16:03:04 -0500
commita749f1c648f2b9bf1a0b0b10e2da4c1c4e3d431d (patch)
tree91bdfc947ac2c6618bace6524cada16e2c5599cf
parent5fbd17e369ca30a47ab8a2eda0b2f2ea9b690bb4 (diff)
parent6a67b20ddd458d71a1d63746504d91b1acea9b2b (diff)
downloademacs-a749f1c648f2b9bf1a0b0b10e2da4c1c4e3d431d.tar.gz
emacs-a749f1c648f2b9bf1a0b0b10e2da4c1c4e3d431d.zip
Shrink EIEIO object header. Move generics to eieio-generic.el.
-rw-r--r--etc/NEWS5
-rw-r--r--lisp/ChangeLog256
-rw-r--r--lisp/cedet/ChangeLog49
-rw-r--r--lisp/cedet/ede.el10
-rw-r--r--lisp/cedet/ede/base.el21
-rw-r--r--lisp/cedet/ede/custom.el4
-rw-r--r--lisp/cedet/ede/proj.el2
-rw-r--r--lisp/cedet/ede/project-am.el8
-rw-r--r--lisp/cedet/ede/speedbar.el8
-rw-r--r--lisp/cedet/semantic.el87
-rw-r--r--lisp/cedet/semantic/bovine/make.el5
-rw-r--r--lisp/cedet/semantic/complete.el4
-rw-r--r--lisp/cedet/semantic/db-ebrowse.el2
-rw-r--r--lisp/cedet/semantic/db-el.el2
-rw-r--r--lisp/cedet/semantic/db-file.el3
-rw-r--r--lisp/cedet/semantic/db-find.el6
-rw-r--r--lisp/cedet/semantic/db-typecache.el2
-rw-r--r--lisp/cedet/semantic/db.el4
-rw-r--r--lisp/cedet/semantic/ede-grammar.el2
-rw-r--r--lisp/cedet/semantic/fw.el19
-rw-r--r--lisp/cedet/semantic/grammar.el9
-rw-r--r--lisp/cedet/semantic/scope.el4
-rw-r--r--lisp/cedet/srecode/compile.el8
-rw-r--r--lisp/cedet/srecode/fields.el2
-rw-r--r--lisp/cedet/srecode/insert.el10
-rw-r--r--lisp/cedet/srecode/map.el2
-rw-r--r--lisp/emacs-lisp/chart.el10
-rw-r--r--lisp/emacs-lisp/eieio-base.el123
-rw-r--r--lisp/emacs-lisp/eieio-core.el1797
-rw-r--r--lisp/emacs-lisp/eieio-custom.el50
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el14
-rw-r--r--lisp/emacs-lisp/eieio-generic.el904
-rw-r--r--lisp/emacs-lisp/eieio-opt.el175
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el10
-rw-r--r--lisp/emacs-lisp/eieio.el498
-rw-r--r--lisp/gnus/ChangeLog12
-rw-r--r--lisp/gnus/registry.el2
-rw-r--r--test/ChangeLog71
-rw-r--r--test/automated/eieio-test-methodinvoke.el58
-rw-r--r--test/automated/eieio-test-persist.el17
-rw-r--r--test/automated/eieio-tests.el124
41 files changed, 2398 insertions, 2001 deletions
diff --git a/etc/NEWS b/etc/NEWS
index f22309e2fac..1f503ceab82 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -194,6 +194,11 @@ the old behavior -- *shell* buffer displays in current window -- use
194(add-to-list 'display-buffer-alist 194(add-to-list 'display-buffer-alist
195 '("^\\*shell\\*$" . (display-buffer-same-window))). 195 '("^\\*shell\\*$" . (display-buffer-same-window))).
196 196
197
198** EIEIO
199*** The <class>-list-p and <class>-child-p functions are declared obsolete.
200*** The <class> variables are declared obsolete.
201*** The <initarg> variables are declared obsolete.
197** ido 202** ido
198*** New command `ido-bury-buffer-at-head' bound to C-S-b 203*** New command `ido-bury-buffer-at-head' bound to C-S-b
199Bury the buffer at the head of `ido-matches', analogous to how C-k 204Bury the buffer at the head of `ido-matches', analogous to how C-k
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 4077e351ba8..bca8d28b1a5 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,255 @@
12015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/eieio.el (defclass): Move from eieio-defclass all the code
4 that creates functions, and most of the sanity checks.
5 Mark as obsolete the <class>-child-p function.
6 * emacs-lisp/eieio-core.el (eieio--define-field-accessors): Remove.
7 (eieio--class, eieio--object): Use cl-defstruct.
8 (eieio--object-num-slots): Define manually.
9 (eieio-defclass-autoload): Use eieio--class-make.
10 (eieio-defclass-internal): Rename from eieio-defclass. Move all the
11 `(lambda...) definitions and most of the sanity checks to `defclass'.
12 Mark as obsolete the <class>-list-p function, the <class> variable and
13 the <initarg> variables. Use pcase-dolist.
14 (eieio-defclass): New compatibility function.
15 * emacs-lisp/eieio-opt.el (eieio-build-class-alist)
16 (eieio-class-speedbar): Don't use eieio-default-superclass var.
17
182015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
19
20 * emacs-lisp/eieio-generic.el: New file.
21 * emacs-lisp/eieio-core.el: Move all generic function code to
22 eieio-generic.el.
23 (eieio--defmethod): Declare.
24
25 * emacs-lisp/eieio.el: Require eieio-generic. Move all generic
26 function code to eieio-generic.el.
27 * emacs-lisp/eieio-opt.el (eieio-help-generic): Move to
28 eieio-generic.el.
29 * emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke): Update call
30 to eieio--generic-call.
31 * emacs-lisp/eieio-base.el (eieio-instance-inheritor): Don't use
32 <class>-child type.
33
342015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
35
36 * emacs-lisp/chart.el (chart-add-sequence, chart-bar-quickie):
37 Don't use <class> as a variable.
38
39 * emacs-lisp/eieio.el (same-class-p): Accept class object as well.
40 (call-next-method): Simplify.
41 (clone): Obey eieio-backward-compatibility.
42
43 * emacs-lisp/eieio-opt.el (eieio-read-generic-p): Remove.
44 (eieio-read-generic): Use `generic-p' instead.
45
46 * emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var.
47 (eieio-defclass-autoload): Obey it.
48 (eieio--class-object): Improve error behavior.
49 (eieio-class-children-fast, same-class-fast-p): Remove. Inline at
50 every use site.
51 (eieio--defgeneric-form-primary-only): Rename from
52 eieio-defgeneric-form-primary-only; update all callers.
53 (eieio--defgeneric-form-primary-only-one): Rename from
54 eieio-defgeneric-form-primary-only-one; update all callers.
55 (eieio-defgeneric-reset-generic-form)
56 (eieio-defgeneric-reset-generic-form-primary-only)
57 (eieio-defgeneric-reset-generic-form-primary-only-one): Remove.
58 (eieio--method-optimize-primary): New function to replace them.
59 (eieio--defmethod, eieio-defmethod): Use it.
60 (eieio--perform-slot-validation): Rename from
61 eieio-perform-slot-validation; update all callers.
62 (eieio--validate-slot-value): Rename from eieio-validate-slot-value.
63 Change `class' to be a class object. Update all callers.
64 (eieio--validate-class-slot-value): Rename from
65 eieio-validate-class-slot-value. Change `class' to be a class object.
66 Update all callers.
67 (eieio-oset-default): Accept class object as well.
68 (eieio--generic-call-primary-only): Rename from
69 eieio-generic-call-primary-only. Update all callers.
70
71 * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
72 Improve error messages.
73 (eieio-persistent-slot-type-is-class-p): Handle `list-of' types, as
74 well as user-defined types. Emit errors for legacy types like
75 <class>-child and <class>-list, if not eieio-backward-compatibility.
76
772015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
78
79 * emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
80 (eieio--class-slot-initarg): Rename from class-slot-initarg.
81 Change `class' arg to be a class object. Update all callers.
82 (call-next-method): Adjust to new return value of `eieio-generic-form'.
83 (eieio-default-superclass): Set var to the class object.
84 (eieio-edebug-prin1-to-string): Fix recursive call for lists.
85 Change print behavior to affect class objects rather than
86 class symbols.
87
88 * emacs-lisp/eieio-core.el (eieio-class-object): New function.
89 (eieio-class-parents-fast): Remove macro.
90 (eieio--class-option-assoc): Rename from class-option-assoc.
91 Update all callers.
92 (eieio--class-option): Rename from class-option. Change `class' arg to
93 be a class object. Update all callers.
94 (eieio--class-method-invocation-order): Rename from
95 class-method-invocation-order. Change `class' arg to be a class
96 object. Update all callers.
97 (eieio-defclass-autoload, eieio-defclass): Set the `parent' field to
98 a list of class objects rather than names.
99 (eieio-defclass): Remove redundant quotes. Use `eieio-oref-default'
100 for accessors to class allocated slots.
101 (eieio--perform-slot-validation-for-default): Rename from
102 eieio-perform-slot-validation-for-default. Update all callers.
103 (eieio--add-new-slot): Rename from eieio-add-new-slot.
104 Update all callers. Use push.
105 (eieio-copy-parents-into-subclass): Adjust to new content of
106 `parent' field. Use dolist.
107 (eieio-oref): Remove support for providing a class rather than
108 an object.
109 (eieio-oref-default): Prefer class objects over class names.
110 (eieio--slot-originating-class-p): Rename from
111 eieio-slot-originating-class-p. Update all callers. Use `or'.
112 (eieio--slot-name-index): Turn check into assertion.
113 (eieio--class-slot-name-index): Rename from
114 eieio-class-slot-name-index. Change `class' arg to be a class object.
115 Update all callers.
116 (eieio-attribute-to-initarg): Move to eieio-test-persist.el.
117 (eieio--c3-candidate): Rename from eieio-c3-candidate.
118 Update all callers.
119 (eieio--c3-merge-lists): Rename from eieio-c3-merge-lists.
120 Update all callers.
121 (eieio--class-precedence-c3): Rename from eieio-class-precedence-c3.
122 Update all callers.
123 (eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs.
124 Update all callers.
125 (eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs.
126 Update all callers. Adjust to new `parent' content.
127 (eieio--class-precedence-list): Rename from -class-precedence-list.
128 Update all callers.
129 (eieio-generic-call): Use autoloadp and autoload-do-load.
130 Slight simplification.
131 (eieio-generic-call, eieio-generic-call-primary-only): Adjust to new
132 return value of `eieio-generic-form'.
133 (eieiomt-add): Index the hashtable with class objects rather than
134 class names.
135 (eieio-generic-form): Accept class objects as well.
136
137 * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
138 Adjust to new convention for eieio-persistent-validate/fix-slot-value.
139 (eieio-persistent-validate/fix-slot-value):
140 Change `class' arg to be a class object. Update all callers.
141
1422015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
143
144 * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects
145 additionally to class names.
146
147 * emacs-lisp/eieio-core.el (eieio--with-scoped-class): Use let-binding.
148 (object): Remove first (constant) slot; rename second to `class-tag'.
149 (eieio--object-class-object, eieio--object-class-name): New funs
150 to replace eieio--object-class.
151 (eieio--class-object, eieio--class-p): New functions.
152 (same-class-fast-p): Make it a defsubst, change its implementation
153 to check the class objects rather than their names.
154 (eieio-object-p): Rewrite.
155 (eieio-defclass): Adjust the object initialization according to the new
156 object layout.
157 (eieio--scoped-class): Declare it returns a class object (not a class
158 name any more). Adjust calls accordingly (along with calls to
159 eieio--with-scoped-class).
160 (eieio--slot-name-index): Rename from eieio-slot-name-index and change
161 its class arg to be a class object. Adjust callers accordingly.
162 (eieio-slot-originating-class-p): Make its start-class arg a class
163 object. Adjust all callers.
164 (eieio--initarg-to-attribute): Rename from eieio-initarg-to-attribute.
165 Make its `class' arg a class object. Adjust all callers.
166
167 * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
168 Use eieio--slot-name-index rather than eieio-slot-name-index.
169
1702015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
171
172 * emacs-lisp/eieio.el (make-instance): Simplify by not adding an object
173 name argument.
174 (eieio-object-name): Use eieio-object-name-string.
175 (eieio--object-names): New const.
176 (eieio-object-name-string, eieio-object-set-name-string): Re-implement
177 using a hashtable rather than a built-in slot.
178 (eieio-constructor): Rename from `constructor'. Remove `newname' arg.
179 (clone): Don't mess with the object's "name".
180
181 * emacs-lisp/eieio-custom.el (eieio-widget-test): Remove dummy arg.
182 (eieio-object-value-get): Use eieio-object-set-name-string.
183
184 * emacs-lisp/eieio-core.el (eieio--defalias): Follow aliases.
185 (eieio--object): Remove `name' field.
186 (eieio-defclass): Adjust to new convention where constructors don't
187 take an "object name" any more.
188 (eieio--defgeneric-init-form, eieio--defmethod): Follow aliases.
189 (eieio-validate-slot-value, eieio-oset-default)
190 (eieio-slot-name-index): Don't hardcode eieio--object-num-slots.
191 (eieio-generic-call-primary-only): Simplify.
192
193 * emacs-lisp/eieio-base.el (clone) <eieio-instance-inheritor>:
194 Use call-next-method.
195 (eieio-constructor): Rename from `constructor'.
196 (eieio-persistent-convert-list-to-object): Drop objname.
197 (eieio-persistent-validate/fix-slot-value): Don't hardcode
198 eieio--object-num-slots.
199 (eieio-named): Use a normal slot.
200 (slot-missing) <eieio-named>: Remove.
201 (eieio-object-name-string, eieio-object-set-name-string, clone)
202 <eieio-named>: New methods.
203
2042015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
205
206 * emacs-lisp/eieio-core.el (eieio--class-v): Rename from class-v.
207 (method-*): Add a "eieio--" prefix to those constants.
208
209 * emacs-lisp/eieio.el: Move edebug specs to the corresponding macro.
210
211 * emacs-lisp/eieio-speedbar.el: Use lexical-binding.
212
2132015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
214
215 * emacs-lisp/eieio.el (child-of-class-p): Fix case where `class' is
216 `eieio-default-superclass'.
217
218 * emacs-lisp/eieio-datadebug.el: Use lexical-binding.
219
220 * emacs-lisp/eieio-custom.el: Use lexical-binding.
221 (eieio-object-value-to-abstract): Simplify.
222
223 * emacs-lisp/eieio-opt.el (eieio-build-class-list): Use cl-mapcan.
224 (eieio-build-class-alist): Use dolist.
225 (eieio-all-generic-functions): Adjust to use of hashtables.
226
227 * emacs-lisp/eieio-core.el (class): Rename field symbol-obarray to
228 symbol-hashtable. It contains a hashtable instead of an obarray.
229 (generic-p): Use symbol property `eieio-method-hashtable' instead of
230 `eieio-method-obarray'.
231 (generic-primary-only-p, generic-primary-only-one-p):
232 Slight optimization.
233 (eieio-defclass-autoload-map): Use a hashtable instead of an obarray.
234 (eieio-defclass-autoload, eieio-defclass): Adjust/simplify accordingly.
235 (eieio-class-un-autoload): Use autoload-do-load.
236 (eieio-defclass): Use dolist, cl-pushnew, cl-callf.
237 Use new cl-deftype-satisfies. Adjust to use of hashtables.
238 Don't hardcode the value of eieio--object-num-slots.
239 (eieio-defgeneric-form-primary-only-one): Remove `doc-string' arg.
240 Use a closure rather than a backquoted lambda.
241 (eieio--defmethod): Adjust call accordingly. Set doc-string via the
242 function-documentation property.
243 (eieio-slot-originating-class-p, eieio-slot-name-index)
244 (eieiomt--optimizing-hashtable, eieiomt-install, eieiomt-add)
245 (eieio-generic-form): Adjust to use of hashtables.
246 (eieiomt--sym-optimize): Rename from eieiomt-sym-optimize; take
247 additional class argument.
248 (eieio-generic-call-methodname): Remove, unused.
249
250 * emacs-lisp/eieio-base.el (eieio-persistent-slot-type-is-class-p):
251 Prefer \' to $.
252
12015-01-08 Eli Zaretskii <eliz@gnu.org> 2532015-01-08 Eli Zaretskii <eliz@gnu.org>
2 254
3 * simple.el (line-move-visual): When converting X pixel coordinate 255 * simple.el (line-move-visual): When converting X pixel coordinate
@@ -609,8 +861,8 @@
609 * electric.el (Electric-pop-up-window): 861 * electric.el (Electric-pop-up-window):
610 * help.el (resize-temp-buffer-window): Call fit-window-to-buffer 862 * help.el (resize-temp-buffer-window): Call fit-window-to-buffer
611 with `preserve-size' t. 863 with `preserve-size' t.
612 * minibuffer.el (minibuffer-completion-help): Use 864 * minibuffer.el (minibuffer-completion-help):
613 `resize-temp-buffer-window' instead of `fit-window-to-buffer' 865 Use `resize-temp-buffer-window' instead of `fit-window-to-buffer'
614 (Bug#19355). Preserve size of completions window. 866 (Bug#19355). Preserve size of completions window.
615 * register.el (register-preview): Preserve size of register 867 * register.el (register-preview): Preserve size of register
616 preview window. 868 preview window.
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog
index 367ed9f41c8..5c958350ff0 100644
--- a/lisp/cedet/ChangeLog
+++ b/lisp/cedet/ChangeLog
@@ -1,3 +1,52 @@
12015-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 Don't use <class> as a variable and don't assume that <class>-list-p is
4 automatically defined.
5
6 * ede/speedbar.el (ede-speedbar-compile-line)
7 (ede-speedbar-get-top-project-for-line):
8 * ede.el (ede-buffer-belongs-to-target-p)
9 (ede-buffer-belongs-to-project-p, ede-build-forms-menu)
10 (ede-add-project-to-global-list):
11 * semantic/db-typecache.el (semanticdb-get-typecache):
12 * semantic/db-file.el (semanticdb-load-database):
13 * semantic/db-el.el (semanticdb-elisp-sym->tag):
14 * semantic/db-ebrowse.el (semanticdb-ebrowse-load-helper):
15 * ede/project-am.el (project-am-preferred-target-type):
16 * ede/proj.el (ede-proj-load):
17 * ede/custom.el (ede-customize-current-target, ede-customize-target):
18 * semantic/ede-grammar.el ("semantic grammar"):
19 * semantic/scope.el (semantic-scope-reset-cache)
20 (semantic-calculate-scope):
21 * srecode/map.el (srecode-map-update-map):
22 * srecode/insert.el (srecode-insert-show-error-report)
23 (srecode-insert-method, srecode-insert-include-lookup)
24 (srecode-insert-method):
25 * srecode/fields.el (srecode-active-template-region):
26 * srecode/compile.el (srecode-flush-active-templates)
27 (srecode-compile-inserter): Don't use <class> as a variable.
28 Use `oref-default' for class slots.
29
30 * semantic/grammar.el (semantic-grammar-eldoc-last-data): New var.
31 (semantic-grammar-eldoc-get-macro-docstring): Use it instead of
32 eldoc-last-data.
33 * semantic/fw.el (semantic-exit-on-input): Use `declare'.
34 (semantic-throw-on-input): Use `with-current-buffer'.
35 * semantic/db.el (semanticdb-abstract-table-list): Define if not
36 pre-defined.
37 * semantic/db-find.el (semanticdb-find-tags-collector):
38 Use save-current-buffer.
39 (semanticdb-find-tags-collector): Don't use <class> as a variable.
40 * semantic/complete.el (semantic-complete-active-default)
41 (semantic-complete-current-matched-tag): Declare.
42 (semantic-complete-inline-custom-type): Don't use <class> as a variable.
43 * semantic/bovine/make.el (semantic-analyze-possible-completions):
44 Use with-current-buffer.
45 * semantic.el (semantic-parser-warnings): Declare.
46 * ede/base.el (ede-target-list): Define if not pre-defined.
47 (ede-with-projectfile): Prefer find-file-noselect over
48 save-window-excursion.
49
12014-12-22 Stefan Monnier <monnier@iro.umontreal.ca> 502014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
2 51
3 * srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children. 52 * srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children.
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index edf87f640cf..87cfb85b2c2 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -248,12 +248,12 @@ Argument LIST-O-O is the list of objects to choose from."
248 (let ((obj ede-object)) 248 (let ((obj ede-object))
249 (if (consp obj) 249 (if (consp obj)
250 (setq obj (car obj))) 250 (setq obj (car obj)))
251 (and obj (obj-of-class-p obj ede-target)))) 251 (and obj (obj-of-class-p obj 'ede-target))))
252 252
253(defun ede-buffer-belongs-to-project-p () 253(defun ede-buffer-belongs-to-project-p ()
254 "Return non-nil if this buffer belongs to at least one project." 254 "Return non-nil if this buffer belongs to at least one project."
255 (if (or (null ede-object) (consp ede-object)) nil 255 (if (or (null ede-object) (consp ede-object)) nil
256 (obj-of-class-p ede-object-project ede-project))) 256 (obj-of-class-p ede-object-project 'ede-project)))
257 257
258(defun ede-menu-obj-of-class-p (class) 258(defun ede-menu-obj-of-class-p (class)
259 "Return non-nil if some member of `ede-object' is a child of CLASS." 259 "Return non-nil if some member of `ede-object' is a child of CLASS."
@@ -281,7 +281,7 @@ Argument MENU-DEF is the menu definition to use."
281 ;; First, collect the build items from the project 281 ;; First, collect the build items from the project
282 (setq newmenu (append newmenu (ede-menu-items-build obj t))) 282 (setq newmenu (append newmenu (ede-menu-items-build obj t)))
283 ;; Second, declare the current target menu items 283 ;; Second, declare the current target menu items
284 (if (and ede-obj (ede-menu-obj-of-class-p ede-target)) 284 (if (and ede-obj (ede-menu-obj-of-class-p 'ede-target))
285 (while ede-obj 285 (while ede-obj
286 (setq newmenu (append newmenu 286 (setq newmenu (append newmenu
287 (ede-menu-items-build (car ede-obj) t)) 287 (ede-menu-items-build (car ede-obj) t))
@@ -1078,7 +1078,7 @@ On success, return the added project."
1078 (error "No project created to add to master list")) 1078 (error "No project created to add to master list"))
1079 (when (not (eieio-object-p proj)) 1079 (when (not (eieio-object-p proj))
1080 (error "Attempt to add non-object to master project list")) 1080 (error "Attempt to add non-object to master project list"))
1081 (when (not (obj-of-class-p proj ede-project-placeholder)) 1081 (when (not (obj-of-class-p proj 'ede-project-placeholder))
1082 (error "Attempt to add a non-project to the ede projects list")) 1082 (error "Attempt to add a non-project to the ede projects list"))
1083 (add-to-list 'ede-projects proj) 1083 (add-to-list 'ede-projects proj)
1084 proj) 1084 proj)
@@ -1099,6 +1099,8 @@ Flush the dead projects from the project cache."
1099 (ede-delete-project-from-global-list D)) 1099 (ede-delete-project-from-global-list D))
1100 )) 1100 ))
1101 1101
1102(defvar ede--disable-inode) ;Defined in ede/files.el.
1103
1102(defun ede-global-list-sanity-check () 1104(defun ede-global-list-sanity-check ()
1103 "Perform a sanity check to make sure there are no duplicate projects." 1105 "Perform a sanity check to make sure there are no duplicate projects."
1104 (interactive) 1106 (interactive)
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el
index 9f4fa45ff3a..ce7857b53a3 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -159,6 +159,9 @@ and querying them will cause the actual project to get loaded.")
159;; Projects can also affect how EDE works, by changing what appears in 159;; Projects can also affect how EDE works, by changing what appears in
160;; the EDE menu, or how some keys are bound. 160;; the EDE menu, or how some keys are bound.
161;; 161;;
162(unless (fboundp 'ede-target-list-p)
163 (cl-deftype ede-target-list () '(list-of ede-target)))
164
162(defclass ede-project (ede-project-placeholder) 165(defclass ede-project (ede-project-placeholder)
163 ((subproj :initform nil 166 ((subproj :initform nil
164 :type list 167 :type list
@@ -287,16 +290,18 @@ All specific project types must derive from this project."
287;; 290;;
288(defmacro ede-with-projectfile (obj &rest forms) 291(defmacro ede-with-projectfile (obj &rest forms)
289 "For the project in which OBJ resides, execute FORMS." 292 "For the project in which OBJ resides, execute FORMS."
290 `(save-window-excursion 293 (declare (indent 1))
291 (let* ((pf (if (obj-of-class-p ,obj ede-target) 294 (unless (symbolp obj)
292 (ede-target-parent ,obj) 295 (message "Beware! ede-with-projectfile's first arg is copied: %S" obj))
293 ,obj)) 296 `(let* ((pf (if (obj-of-class-p ,obj 'ede-target)
294 (dbka (get-file-buffer (oref pf file)))) 297 (ede-target-parent ,obj)
295 (if (not dbka) (find-file (oref pf file)) 298 ,obj))
296 (switch-to-buffer dbka)) 299 (dbka (get-file-buffer (oref pf file))))
300 (with-current-buffer
301 (if (not dbka) (find-file-noselect (oref pf file))
302 dbka)
297 ,@forms 303 ,@forms
298 (if (not dbka) (kill-buffer (current-buffer)))))) 304 (if (not dbka) (kill-buffer (current-buffer))))))
299(put 'ede-with-projectfile 'lisp-indent-function 1)
300 305
301;;; The EDE persistent cache. 306;;; The EDE persistent cache.
302;; 307;;
diff --git a/lisp/cedet/ede/custom.el b/lisp/cedet/ede/custom.el
index 3cc3a48c27a..a39b4880283 100644
--- a/lisp/cedet/ede/custom.el
+++ b/lisp/cedet/ede/custom.el
@@ -61,7 +61,7 @@
61 "Edit fields of the current target through EIEIO & Custom." 61 "Edit fields of the current target through EIEIO & Custom."
62 (interactive) 62 (interactive)
63 (require 'eieio-custom) 63 (require 'eieio-custom)
64 (if (not (obj-of-class-p ede-object ede-target)) 64 (if (not (obj-of-class-p ede-object 'ede-target))
65 (error "Current file is not part of a target")) 65 (error "Current file is not part of a target"))
66 (ede-customize-target ede-object)) 66 (ede-customize-target ede-object))
67 67
@@ -72,7 +72,7 @@
72 "Edit fields of the current target through EIEIO & Custom. 72 "Edit fields of the current target through EIEIO & Custom.
73OBJ is the target object to customize." 73OBJ is the target object to customize."
74 (require 'eieio-custom) 74 (require 'eieio-custom)
75 (if (and obj (not (obj-of-class-p obj ede-target))) 75 (if (and obj (not (obj-of-class-p obj 'ede-target)))
76 (error "No logical target to customize")) 76 (error "No logical target to customize"))
77 (ede-customize obj)) 77 (ede-customize obj))
78 78
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 1ea16570467..fd789b3857d 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -297,7 +297,7 @@ for the tree being read in. If ROOTPROJ is nil, then assume that
297the PROJECT being read in is the root project." 297the PROJECT being read in is the root project."
298 (save-excursion 298 (save-excursion
299 (let ((ret (eieio-persistent-read (concat project "Project.ede") 299 (let ((ret (eieio-persistent-read (concat project "Project.ede")
300 ede-proj-project)) 300 'ede-proj-project))
301 (subdirs (directory-files project nil "[^.].*" nil))) 301 (subdirs (directory-files project nil "[^.].*" nil)))
302 (if (not (object-of-class-p ret 'ede-proj-project)) 302 (if (not (object-of-class-p ret 'ede-proj-project))
303 (error "Corrupt project file")) 303 (error "Corrupt project file"))
diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el
index 75fd195105f..d0ca8091c90 100644
--- a/lisp/cedet/ede/project-am.el
+++ b/lisp/cedet/ede/project-am.el
@@ -853,13 +853,13 @@ Argument FILE is the file to extract the end directory name from."
853(defun project-am-preferred-target-type (file) 853(defun project-am-preferred-target-type (file)
854 "For FILE, return the preferred type for that file." 854 "For FILE, return the preferred type for that file."
855 (cond ((string-match "\\.texi?\\(nfo\\)$" file) 855 (cond ((string-match "\\.texi?\\(nfo\\)$" file)
856 project-am-texinfo) 856 'project-am-texinfo)
857 ((string-match "\\.[0-9]$" file) 857 ((string-match "\\.[0-9]$" file)
858 project-am-man) 858 'project-am-man)
859 ((string-match "\\.el$" file) 859 ((string-match "\\.el$" file)
860 project-am-lisp) 860 'project-am-lisp)
861 (t 861 (t
862 project-am-program))) 862 'project-am-program)))
863 863
864(defmethod ede-buffer-header-file((this project-am-objectcode) buffer) 864(defmethod ede-buffer-header-file((this project-am-objectcode) buffer)
865 "There are no default header files." 865 "There are no default header files."
diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el
index fc26ec948a2..e08562a3738 100644
--- a/lisp/cedet/ede/speedbar.el
+++ b/lisp/cedet/ede/speedbar.el
@@ -121,9 +121,9 @@ Argument DIR is the directory from which to derive the list of objects."
121 (let ((obj (eieio-speedbar-find-nearest-object))) 121 (let ((obj (eieio-speedbar-find-nearest-object)))
122 (if (not (eieio-object-p obj)) 122 (if (not (eieio-object-p obj))
123 nil 123 nil
124 (cond ((obj-of-class-p obj ede-project) 124 (cond ((obj-of-class-p obj 'ede-project)
125 (project-compile-project obj)) 125 (project-compile-project obj))
126 ((obj-of-class-p obj ede-target) 126 ((obj-of-class-p obj 'ede-target)
127 (project-compile-target obj)) 127 (project-compile-target obj))
128 (t (error "Error in speedbar structure")))))) 128 (t (error "Error in speedbar structure"))))))
129 129
@@ -133,9 +133,9 @@ Argument DIR is the directory from which to derive the list of objects."
133 (let ((obj (eieio-speedbar-find-nearest-object))) 133 (let ((obj (eieio-speedbar-find-nearest-object)))
134 (if (not (eieio-object-p obj)) 134 (if (not (eieio-object-p obj))
135 (error "Error in speedbar or ede structure") 135 (error "Error in speedbar or ede structure")
136 (if (obj-of-class-p obj ede-target) 136 (if (obj-of-class-p obj 'ede-target)
137 (setq obj (ede-target-parent obj))) 137 (setq obj (ede-target-parent obj)))
138 (if (obj-of-class-p obj ede-project) 138 (if (obj-of-class-p obj 'ede-project)
139 obj 139 obj
140 (error "Error in speedbar or ede structure"))))) 140 (error "Error in speedbar or ede structure")))))
141 141
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 7afe67b3207..81a97884554 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -573,6 +573,7 @@ string."
573;; The best way to call the parser from programs is via 573;; The best way to call the parser from programs is via
574;; `semantic-fetch-tags'. This, in turn, uses other internal 574;; `semantic-fetch-tags'. This, in turn, uses other internal
575;; API functions which plug-in parsers can take advantage of. 575;; API functions which plug-in parsers can take advantage of.
576(defvar semantic-parser-warnings)
576 577
577(defun semantic-fetch-tags () 578(defun semantic-fetch-tags ()
578 "Fetch semantic tags from the current buffer. 579 "Fetch semantic tags from the current buffer.
@@ -602,49 +603,49 @@ was marked unparseable, then do nothing, and return the cache."
602 (garbage-collect) 603 (garbage-collect)
603 (cond 604 (cond
604 605
605;;;; Try the incremental parser to do a fast update. 606 ;; Try the incremental parser to do a fast update.
606 ((semantic-parse-tree-needs-update-p) 607 ((semantic-parse-tree-needs-update-p)
607 (setq res (semantic-parse-changes)) 608 (setq res (semantic-parse-changes))
608 (if (semantic-parse-tree-needs-rebuild-p) 609 (if (semantic-parse-tree-needs-rebuild-p)
609 ;; If the partial reparse fails, jump to a full reparse. 610 ;; If the partial reparse fails, jump to a full reparse.
610 (semantic-fetch-tags) 611 (semantic-fetch-tags)
611 ;; Clear the cache of unmatched syntax tokens 612 ;; Clear the cache of unmatched syntax tokens
612 ;; 613 ;;
613 ;; NOTE TO SELF: 614 ;; NOTE TO SELF:
614 ;; 615 ;;
615 ;; Move this into the incremental parser. This is a bug. 616 ;; Move this into the incremental parser. This is a bug.
616 ;; 617 ;;
617 (semantic-clear-unmatched-syntax-cache) 618 (semantic-clear-unmatched-syntax-cache)
618 (run-hook-with-args ;; Let hooks know the updated tags 619 (run-hook-with-args ;; Let hooks know the updated tags
619 'semantic-after-partial-cache-change-hook res)) 620 'semantic-after-partial-cache-change-hook res))
620 (setq semantic--completion-cache nil)) 621 (setq semantic--completion-cache nil))
621 622
622;;;; Parse the whole system. 623 ;; Parse the whole system.
623 ((semantic-parse-tree-needs-rebuild-p) 624 ((semantic-parse-tree-needs-rebuild-p)
624 ;; Use Emacs's built-in progress-reporter (only interactive). 625 ;; Use Emacs's built-in progress-reporter (only interactive).
625 (if noninteractive 626 (if noninteractive
626 (setq res (semantic-parse-region (point-min) (point-max))) 627 (setq res (semantic-parse-region (point-min) (point-max)))
627 (let ((semantic--progress-reporter 628 (let ((semantic--progress-reporter
628 (and (>= (point-max) semantic-minimum-working-buffer-size) 629 (and (>= (point-max) semantic-minimum-working-buffer-size)
629 (eq semantic-working-type 'percent) 630 (eq semantic-working-type 'percent)
630 (make-progress-reporter 631 (make-progress-reporter
631 (semantic-parser-working-message (buffer-name)) 632 (semantic-parser-working-message (buffer-name))
632 0 100)))) 633 0 100))))
633 (setq res (semantic-parse-region (point-min) (point-max))) 634 (setq res (semantic-parse-region (point-min) (point-max)))
634 (if semantic--progress-reporter 635 (if semantic--progress-reporter
635 (progress-reporter-done semantic--progress-reporter)))) 636 (progress-reporter-done semantic--progress-reporter))))
636 637
637 ;; Clear the caches when we see there were no errors. 638 ;; Clear the caches when we see there were no errors.
638 ;; But preserve the unmatched syntax cache and warnings! 639 ;; But preserve the unmatched syntax cache and warnings!
639 (let (semantic-unmatched-syntax-cache 640 (let (semantic-unmatched-syntax-cache
640 semantic-unmatched-syntax-cache-check 641 semantic-unmatched-syntax-cache-check
641 semantic-parser-warnings) 642 semantic-parser-warnings)
642 (semantic-clear-toplevel-cache)) 643 (semantic-clear-toplevel-cache))
643 ;; Set up the new overlays 644 ;; Set up the new overlays
644 (semantic--tag-link-list-to-buffer res) 645 (semantic--tag-link-list-to-buffer res)
645 ;; Set up the cache with the new results 646 ;; Set up the cache with the new results
646 (semantic--set-buffer-cache res) 647 (semantic--set-buffer-cache res)
647 )))) 648 ))))
648 649
649 ;; Always return the current parse tree. 650 ;; Always return the current parse tree.
650 semantic--buffer-cache) 651 semantic--buffer-cache)
diff --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el
index 6ba02ee2006..c001a4dab5f 100644
--- a/lisp/cedet/semantic/bovine/make.el
+++ b/lisp/cedet/semantic/bovine/make.el
@@ -178,9 +178,8 @@ This is the same as a regular prototype."
178 makefile-mode (context) 178 makefile-mode (context)
179 "Return a list of possible completions in a Makefile. 179 "Return a list of possible completions in a Makefile.
180Uses default implementation, and also gets a list of filenames." 180Uses default implementation, and also gets a list of filenames."
181 (save-excursion 181 (require 'semantic/analyze/complete)
182 (require 'semantic/analyze/complete) 182 (with-current-buffer (oref context buffer)
183 (set-buffer (oref context buffer))
184 (let* ((normal (semantic-analyze-possible-completions-default context)) 183 (let* ((normal (semantic-analyze-possible-completions-default context))
185 (classes (oref context :prefixclass)) 184 (classes (oref context :prefixclass))
186 (filetags nil)) 185 (filetags nil))
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index f1fbc7538c2..3f726ee56fd 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -188,6 +188,8 @@ Value should be a ... what?")
188 "Default history variable for any unhistoried prompt. 188 "Default history variable for any unhistoried prompt.
189Keeps STRINGS only in the history.") 189Keeps STRINGS only in the history.")
190 190
191(defvar semantic-complete-active-default)
192(defvar semantic-complete-current-matched-tag)
191 193
192(defun semantic-complete-read-tag-engine (collector displayor prompt 194(defun semantic-complete-read-tag-engine (collector displayor prompt
193 default-tag initial-input 195 default-tag initial-input
@@ -1871,7 +1873,7 @@ completion text in ghost text."
1871 (list 'const 1873 (list 'const
1872 :tag doc1 1874 :tag doc1
1873 C))) 1875 C)))
1874 (eieio-build-class-alist semantic-displayor-abstract t)) 1876 (eieio-build-class-alist 'semantic-displayor-abstract t))
1875 ) 1877 )
1876 "Possible options for inline completion displayors. 1878 "Possible options for inline completion displayors.
1877Use this to enable custom editing.") 1879Use this to enable custom editing.")
diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el
index 6ed3cdb7eb5..2590dd1208d 100644
--- a/lisp/cedet/semantic/db-ebrowse.el
+++ b/lisp/cedet/semantic/db-ebrowse.el
@@ -192,7 +192,7 @@ is specified by `semanticdb-default-save-directory'."
192If DIRECTORY is found to be defunct, it won't load the DB, and will 192If DIRECTORY is found to be defunct, it won't load the DB, and will
193warn instead." 193warn instead."
194 (if (file-directory-p directory) 194 (if (file-directory-p directory)
195 (semanticdb-create-database semanticdb-project-database-ebrowse 195 (semanticdb-create-database 'semanticdb-project-database-ebrowse
196 directory) 196 directory)
197 (let* ((BF (semanticdb-ebrowse-file-for-directory directory)) 197 (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
198 (BFL (concat BF "-load.el")) 198 (BFL (concat BF "-load.el"))
diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el
index 8b988be77bb..be9ffe31b87 100644
--- a/lisp/cedet/semantic/db-el.el
+++ b/lisp/cedet/semantic/db-el.el
@@ -225,7 +225,7 @@ TOKTYPE is a hint to the type of tag desired."
225 (semantic-elisp-desymbolify 225 (semantic-elisp-desymbolify
226 ;; FIXME: This only gives the instance slots and ignores the 226 ;; FIXME: This only gives the instance slots and ignores the
227 ;; class-allocated slots. 227 ;; class-allocated slots.
228 (eieio--class-public-a (find-class semanticdb-project-database))) ;; slots ;FIXME: eieio-- 228 (eieio--class-public-a (find-class 'semanticdb-project-database))) ;; slots ;FIXME: eieio--
229 (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents 229 (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents
230 )) 230 ))
231 ((not toktype) 231 ((not toktype)
diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el
index 5b76d851b1d..0360e0680e7 100644
--- a/lisp/cedet/semantic/db-file.el
+++ b/lisp/cedet/semantic/db-file.el
@@ -158,7 +158,8 @@ If DIRECTORY doesn't exist, create a new one."
158(defun semanticdb-load-database (filename) 158(defun semanticdb-load-database (filename)
159 "Load the database FILENAME." 159 "Load the database FILENAME."
160 (condition-case foo 160 (condition-case foo
161 (let* ((r (eieio-persistent-read filename semanticdb-project-database-file)) 161 (let* ((r (eieio-persistent-read filename
162 'semanticdb-project-database-file))
162 (c (semanticdb-get-database-tables r)) 163 (c (semanticdb-get-database-tables r))
163 (tv (oref r semantic-tag-version)) 164 (tv (oref r semantic-tag-version))
164 (fv (oref r semanticdb-version)) 165 (fv (oref r semanticdb-version))
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el
index 08a22fb3b85..dd36cc1a01e 100644
--- a/lisp/cedet/semantic/db-find.el
+++ b/lisp/cedet/semantic/db-find.el
@@ -1114,7 +1114,7 @@ for backward compatibility.
1114If optional argument BRUTISH is non-nil, then ignore include statements, 1114If optional argument BRUTISH is non-nil, then ignore include statements,
1115and search all tables in this project tree." 1115and search all tables in this project tree."
1116 (let (found match) 1116 (let (found match)
1117 (save-excursion 1117 (save-current-buffer
1118 ;; If path is a buffer, set ourselves up in that buffer 1118 ;; If path is a buffer, set ourselves up in that buffer
1119 ;; so that the override methods work correctly. 1119 ;; so that the override methods work correctly.
1120 (when (bufferp path) (set-buffer path)) 1120 (when (bufferp path) (set-buffer path))
@@ -1127,7 +1127,7 @@ and search all tables in this project tree."
1127 ;; databases and not associated with a file. 1127 ;; databases and not associated with a file.
1128 (unless (and find-file-match 1128 (unless (and find-file-match
1129 (obj-of-class-p 1129 (obj-of-class-p
1130 (car tableandtags) semanticdb-search-results-table)) 1130 (car tableandtags) 'semanticdb-search-results-table))
1131 (when (setq match (funcall function 1131 (when (setq match (funcall function
1132 (car tableandtags) (cdr tableandtags))) 1132 (car tableandtags) (cdr tableandtags)))
1133 (when find-file-match 1133 (when find-file-match
@@ -1144,7 +1144,7 @@ and search all tables in this project tree."
1144 ;; `semanticdb-search-results-table', since those are system 1144 ;; `semanticdb-search-results-table', since those are system
1145 ;; databases and not associated with a file. 1145 ;; databases and not associated with a file.
1146 (unless (and find-file-match 1146 (unless (and find-file-match
1147 (obj-of-class-p table semanticdb-search-results-table)) 1147 (obj-of-class-p table 'semanticdb-search-results-table))
1148 (when (and table (setq match (funcall function table nil))) 1148 (when (and table (setq match (funcall function table nil)))
1149 (semanticdb-find-log-activity table match) 1149 (semanticdb-find-log-activity table match)
1150 (when find-file-match 1150 (when find-file-match
diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el
index eb00a57cddd..723b7bd28bc 100644
--- a/lisp/cedet/semantic/db-typecache.el
+++ b/lisp/cedet/semantic/db-typecache.el
@@ -180,7 +180,7 @@ If there is no table, create one, and fill it in."
180(defmethod semanticdb-get-typecache ((db semanticdb-project-database)) 180(defmethod semanticdb-get-typecache ((db semanticdb-project-database))
181 "Retrieve the typecache from the semantic database DB. 181 "Retrieve the typecache from the semantic database DB.
182If there is no table, create one, and fill it in." 182If there is no table, create one, and fill it in."
183 (semanticdb-cache-get db semanticdb-database-typecache) 183 (semanticdb-cache-get db 'semanticdb-database-typecache)
184 ) 184 )
185 185
186 186
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index 43e5e5b435b..b2c1252c502 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -330,6 +330,10 @@ Adds the number of tags in this file to the object print name."
330 330
331;;; DATABASE BASE CLASS 331;;; DATABASE BASE CLASS
332;; 332;;
333(unless (fboundp 'semanticdb-abstract-table-list-p)
334 (cl-deftype semanticdb-abstract-table-list ()
335 '(list-of semanticdb-abstract-table)))
336
333(defclass semanticdb-project-database (eieio-instance-tracker) 337(defclass semanticdb-project-database (eieio-instance-tracker)
334 ((tracking-symbol :initform semanticdb-database-list) 338 ((tracking-symbol :initform semanticdb-database-list)
335 (reference-directory :type string 339 (reference-directory :type string
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
index dc3dfa7f55a..67f0cfeea6d 100644
--- a/lisp/cedet/semantic/ede-grammar.el
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -213,7 +213,7 @@ Argument THIS is the target that should insert stuff."
213;; "Target class for Emacs/Semantic grammar files." nil nil) 213;; "Target class for Emacs/Semantic grammar files." nil nil)
214 214
215(ede-proj-register-target "semantic grammar" 215(ede-proj-register-target "semantic grammar"
216 semantic-ede-proj-target-grammar) 216 'semantic-ede-proj-target-grammar)
217 217
218(provide 'semantic/ede-grammar) 218(provide 'semantic/ede-grammar)
219 219
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 56adf3a6e81..a0c36944d48 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -378,11 +378,11 @@ If FORMS includes a call to `semantic-throw-on-input', then
378if a user presses any key during execution, this form macro 378if a user presses any key during execution, this form macro
379will exit with the value passed to `semantic-throw-on-input'. 379will exit with the value passed to `semantic-throw-on-input'.
380If FORMS completes, then the return value is the same as `progn'." 380If FORMS completes, then the return value is the same as `progn'."
381 (declare (indent 1))
381 `(let ((semantic-current-input-throw-symbol ,symbol) 382 `(let ((semantic-current-input-throw-symbol ,symbol)
382 (semantic--on-input-start-marker (point-marker))) 383 (semantic--on-input-start-marker (point-marker)))
383 (catch ,symbol 384 (catch ,symbol
384 ,@forms))) 385 ,@forms)))
385(put 'semantic-exit-on-input 'lisp-indent-function 1)
386 386
387(defmacro semantic-throw-on-input (from) 387(defmacro semantic-throw-on-input (from)
388 "Exit with `throw' when in `semantic-exit-on-input' on user input. 388 "Exit with `throw' when in `semantic-exit-on-input' on user input.
@@ -391,15 +391,14 @@ to pass to `throw'. It is recommended to use the name of the function
391calling this one." 391calling this one."
392 `(when (and semantic-current-input-throw-symbol 392 `(when (and semantic-current-input-throw-symbol
393 (or (input-pending-p) 393 (or (input-pending-p)
394 (save-excursion 394 (with-current-buffer
395 ;; Timers might run during accept-process-output. 395 ;; Timers might run during accept-process-output.
396 ;; If they redisplay, point must be where the user 396 ;; If they redisplay, point must be where the user
397 ;; expects. (Bug#15045) 397 ;; expects. (Bug#15045)
398 (set-buffer (marker-buffer 398 (marker-buffer semantic--on-input-start-marker)
399 semantic--on-input-start-marker)) 399 (save-excursion
400 (goto-char (marker-position 400 (goto-char semantic--on-input-start-marker)
401 semantic--on-input-start-marker)) 401 (accept-process-output)))))
402 (accept-process-output))))
403 (throw semantic-current-input-throw-symbol ,from))) 402 (throw semantic-current-input-throw-symbol ,from)))
404 403
405 404
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index fc62b221665..7a92a12ed53 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -1665,13 +1665,14 @@ Select the buffer containing the tag's definition, and move point there."
1665(declare-function eldoc-get-fnsym-args-string "eldoc") 1665(declare-function eldoc-get-fnsym-args-string "eldoc")
1666(declare-function eldoc-get-var-docstring "eldoc") 1666(declare-function eldoc-get-var-docstring "eldoc")
1667 1667
1668(defvar semantic-grammar-eldoc-last-data (cons nil nil))
1669
1668(defun semantic-grammar-eldoc-get-macro-docstring (macro expander) 1670(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
1669 "Return a one-line docstring for the given grammar MACRO. 1671 "Return a one-line docstring for the given grammar MACRO.
1670EXPANDER is the name of the function that expands MACRO." 1672EXPANDER is the name of the function that expands MACRO."
1671 (require 'eldoc) 1673 (require 'eldoc)
1672 (if (and (eq expander (aref eldoc-last-data 0)) 1674 (if (eq expander (car semantic-grammar-eldoc-last-data))
1673 (eq 'function (aref eldoc-last-data 2))) 1675 (cdr semantic-grammar-eldoc-last-data)
1674 (aref eldoc-last-data 1)
1675 (let ((doc (help-split-fundoc (documentation expander t) expander))) 1676 (let ((doc (help-split-fundoc (documentation expander t) expander)))
1676 (cond 1677 (cond
1677 (doc 1678 (doc
@@ -1684,7 +1685,7 @@ EXPANDER is the name of the function that expands MACRO."
1684 (setq doc 1685 (setq doc
1685 (eldoc-docstring-format-sym-doc 1686 (eldoc-docstring-format-sym-doc
1686 macro (format "==> %s %s" expander doc) 'default)) 1687 macro (format "==> %s %s" expander doc) 'default))
1687 (eldoc-last-data-store expander doc 'function)) 1688 (setq semantic-grammar-eldoc-last-data (cons expander doc)))
1688 doc))) 1689 doc)))
1689 1690
1690(define-mode-local-override semantic-idle-summary-current-symbol-info 1691(define-mode-local-override semantic-idle-summary-current-symbol-info
diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el
index 2c0dea20107..c56cbc3c126 100644
--- a/lisp/cedet/semantic/scope.el
+++ b/lisp/cedet/semantic/scope.el
@@ -134,7 +134,7 @@ Saves scoping information between runs of the analyzer.")
134 "Get the current cached scope, and reset it." 134 "Get the current cached scope, and reset it."
135 (when semanticdb-current-table 135 (when semanticdb-current-table
136 (let ((co (semanticdb-cache-get semanticdb-current-table 136 (let ((co (semanticdb-cache-get semanticdb-current-table
137 semantic-scope-cache))) 137 'semantic-scope-cache)))
138 (semantic-reset co)))) 138 (semantic-reset co))))
139 139
140(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache) 140(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
@@ -706,7 +706,7 @@ The class returned from the scope calculation is variable
706 (let* ((TAG (semantic-current-tag)) 706 (let* ((TAG (semantic-current-tag))
707 (scopecache 707 (scopecache
708 (semanticdb-cache-get semanticdb-current-table 708 (semanticdb-cache-get semanticdb-current-table
709 semantic-scope-cache)) 709 'semantic-scope-cache))
710 ) 710 )
711 (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag))) 711 (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
712 (semantic-reset scopecache)) 712 (semantic-reset scopecache))
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el
index d899b42b1e1..782121ef5b5 100644
--- a/lisp/cedet/srecode/compile.el
+++ b/lisp/cedet/srecode/compile.el
@@ -87,10 +87,10 @@ for push, pop, and peek for the active template.")
87Useful if something goes wrong in SRecode, and the active template 87Useful if something goes wrong in SRecode, and the active template
88stack is broken." 88stack is broken."
89 (interactive) 89 (interactive)
90 (if (oref srecode-template active) 90 (if (oref-default 'srecode-template active)
91 (when (y-or-n-p (format "%d active templates. Flush? " 91 (when (y-or-n-p (format "%d active templates. Flush? "
92 (length (oref srecode-template active)))) 92 (length (oref-default 'srecode-template active))))
93 (oset-default srecode-template active nil)) 93 (oset-default 'srecode-template active nil))
94 (message "No active templates to flush.")) 94 (message "No active templates to flush."))
95 ) 95 )
96 96
@@ -514,7 +514,7 @@ to the inserter constructor."
514 ;;(message "Compile: %s %S" name props) 514 ;;(message "Compile: %s %S" name props)
515 (if (not key) 515 (if (not key)
516 (apply 'srecode-template-inserter-variable name props) 516 (apply 'srecode-template-inserter-variable name props)
517 (let ((classes (eieio-class-children srecode-template-inserter)) 517 (let ((classes (eieio-class-children 'srecode-template-inserter))
518 (new nil)) 518 (new nil))
519 ;; Loop over the various subclasses and 519 ;; Loop over the various subclasses and
520 ;; create the correct inserter. 520 ;; create the correct inserter.
diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el
index 20852f78b41..f473a0d8261 100644
--- a/lisp/cedet/srecode/fields.el
+++ b/lisp/cedet/srecode/fields.el
@@ -237,7 +237,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
237 237
238(defsubst srecode-active-template-region () 238(defsubst srecode-active-template-region ()
239 "Return the active region for template fields." 239 "Return the active region for template fields."
240 (oref srecode-template-inserted-region active-region)) 240 (oref-default 'srecode-template-inserted-region active-region))
241 241
242(defun srecode-field-post-command () 242(defun srecode-field-post-command ()
243 "Srecode field handler in the post command hook." 243 "Srecode field handler in the post command hook."
diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el
index f1f23bc6f1d..78ec1658859 100644
--- a/lisp/cedet/srecode/insert.el
+++ b/lisp/cedet/srecode/insert.el
@@ -211,7 +211,7 @@ insertions."
211 (propertize " (most recent at bottom)" 'face '(:slant italic)) 211 (propertize " (most recent at bottom)" 'face '(:slant italic))
212 ":\n") 212 ":\n")
213 (data-debug-insert-stuff-list 213 (data-debug-insert-stuff-list
214 (reverse (oref srecode-template active)) "> ") 214 (reverse (oref-default 'srecode-template active)) "> ")
215 ;; Show the current dictionary. 215 ;; Show the current dictionary.
216 (insert (propertize "Dictionary" 'face '(:weight bold)) "\n") 216 (insert (propertize "Dictionary" 'face '(:weight bold)) "\n")
217 (data-debug-insert-thing dictionary "" "> ") 217 (data-debug-insert-thing dictionary "" "> ")
@@ -396,7 +396,7 @@ Specify the :blank argument to enable this inserter.")
396 (pm (point-marker))) 396 (pm (point-marker)))
397 (when (and inbuff 397 (when (and inbuff
398 ;; Don't do this if we are not the active template. 398 ;; Don't do this if we are not the active template.
399 (= (length (oref srecode-template active)) 1)) 399 (= (length (oref-default 'srecode-template active)) 1))
400 400
401 (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin))) 401 (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
402 (indent-according-to-mode) 402 (indent-according-to-mode)
@@ -773,7 +773,7 @@ generalized marker will do something else. See
773 ;; valid. Compare this to the actual template nesting depth and 773 ;; valid. Compare this to the actual template nesting depth and
774 ;; maybe use the override function which is stored in the cdr. 774 ;; maybe use the override function which is stored in the cdr.
775 (if (and srecode-template-inserter-point-override 775 (if (and srecode-template-inserter-point-override
776 (<= (length (oref srecode-template active)) 776 (<= (length (oref-default 'srecode-template active))
777 (car srecode-template-inserter-point-override))) 777 (car srecode-template-inserter-point-override)))
778 ;; Disable the old override while we do this. 778 ;; Disable the old override while we do this.
779 (let ((over (cdr srecode-template-inserter-point-override)) 779 (let ((over (cdr srecode-template-inserter-point-override))
@@ -943,7 +943,7 @@ this template instance."
943 ;; Calculate and store the discovered template 943 ;; Calculate and store the discovered template
944 (let ((tmpl (srecode-template-get-table (srecode-table) 944 (let ((tmpl (srecode-template-get-table (srecode-table)
945 templatenamepart)) 945 templatenamepart))
946 (active (oref srecode-template active)) 946 (active (oref-default 'srecode-template active))
947 ctxt) 947 ctxt)
948 (when (not tmpl) 948 (when (not tmpl)
949 ;; If it isn't just available, scan back through 949 ;; If it isn't just available, scan back through
@@ -1053,7 +1053,7 @@ template where a ^ inserter occurs."
1053 (lexical-let ((inserter1 sti)) 1053 (lexical-let ((inserter1 sti))
1054 (cons 1054 (cons
1055 ;; DEPTH 1055 ;; DEPTH
1056 (+ (length (oref srecode-template active)) 1) 1056 (+ (length (oref-default 'srecode-template active)) 1)
1057 ;; FUNCTION 1057 ;; FUNCTION
1058 (lambda (dict) 1058 (lambda (dict)
1059 (let ((srecode-template-inserter-point-override nil)) 1059 (let ((srecode-template-inserter-point-override nil))
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
index 7224d5942f6..cc0c4ae4427 100644
--- a/lisp/cedet/srecode/map.el
+++ b/lisp/cedet/srecode/map.el
@@ -298,7 +298,7 @@ if that file is NEW, otherwise assume the mode has not changed."
298 (when (not srecode-current-map) 298 (when (not srecode-current-map)
299 (condition-case nil 299 (condition-case nil
300 (setq srecode-current-map 300 (setq srecode-current-map
301 (eieio-persistent-read srecode-map-save-file srecode-map)) 301 (eieio-persistent-read srecode-map-save-file 'srecode-map))
302 (error 302 (error
303 ;; There was an error loading the old map. Create a new one. 303 ;; There was an error loading the old map. Create a new one.
304 (setq srecode-current-map 304 (setq srecode-current-map
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 62b2b5cc6da..851b3bfc6fd 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -422,7 +422,7 @@ or is created with the bounds of SEQ."
422 (if (stringp (car (oref seq data))) 422 (if (stringp (car (oref seq data)))
423 (let ((labels (oref seq data))) 423 (let ((labels (oref seq data)))
424 (if (not axis) 424 (if (not axis)
425 (setq axis (make-instance chart-axis-names 425 (setq axis (make-instance 'chart-axis-names
426 :name (oref seq name) 426 :name (oref seq name)
427 :items labels 427 :items labels
428 :chart c)) 428 :chart c))
@@ -430,7 +430,7 @@ or is created with the bounds of SEQ."
430 (let ((range (cons 0 1)) 430 (let ((range (cons 0 1))
431 (l (oref seq data))) 431 (l (oref seq data)))
432 (if (not axis) 432 (if (not axis)
433 (setq axis (make-instance chart-axis-range 433 (setq axis (make-instance 'chart-axis-range
434 :name (oref seq name) 434 :name (oref seq name)
435 :chart c))) 435 :chart c)))
436 (while l 436 (while l
@@ -577,19 +577,19 @@ labeled NUMTITLE.
577Optional arguments: 577Optional arguments:
578Set the chart's max element display to MAX, and sort lists with 578Set the chart's max element display to MAX, and sort lists with
579SORT-PRED if desired." 579SORT-PRED if desired."
580 (let ((nc (make-instance chart-bar 580 (let ((nc (make-instance 'chart-bar
581 :title title 581 :title title
582 :key-label "8-m" ; This is a text key pic 582 :key-label "8-m" ; This is a text key pic
583 :direction dir 583 :direction dir
584 )) 584 ))
585 (iv (eq dir 'vertical))) 585 (iv (eq dir 'vertical)))
586 (chart-add-sequence nc 586 (chart-add-sequence nc
587 (make-instance chart-sequece 587 (make-instance 'chart-sequece
588 :data namelst 588 :data namelst
589 :name nametitle) 589 :name nametitle)
590 (if iv 'x-axis 'y-axis)) 590 (if iv 'x-axis 'y-axis))
591 (chart-add-sequence nc 591 (chart-add-sequence nc
592 (make-instance chart-sequece 592 (make-instance 'chart-sequece
593 :data numlst 593 :data numlst
594 :name numtitle) 594 :name numtitle)
595 (if iv 'y-axis 'x-axis)) 595 (if iv 'y-axis 'x-axis))
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 7478908051c..9931fbd114e 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -40,7 +40,7 @@
40;; error if a slot is unbound. 40;; error if a slot is unbound.
41(defclass eieio-instance-inheritor () 41(defclass eieio-instance-inheritor ()
42 ((parent-instance :initarg :parent-instance 42 ((parent-instance :initarg :parent-instance
43 :type eieio-instance-inheritor-child 43 :type eieio-instance-inheritor
44 :documentation 44 :documentation
45 "The parent of this instance. 45 "The parent of this instance.
46If a slot of this class is referenced, and is unbound, then the parent 46If a slot of this class is referenced, and is unbound, then the parent
@@ -63,25 +63,10 @@ SLOT-NAME is the offending slot. FN is the function signaling the error."
63 ;; Throw the regular signal. 63 ;; Throw the regular signal.
64 (call-next-method))) 64 (call-next-method)))
65 65
66(defmethod clone ((obj eieio-instance-inheritor) &rest params) 66(defmethod clone ((obj eieio-instance-inheritor) &rest _params)
67 "Clone OBJ, initializing `:parent' to OBJ. 67 "Clone OBJ, initializing `:parent' to OBJ.
68All slots are unbound, except those initialized with PARAMS." 68All slots are unbound, except those initialized with PARAMS."
69 (let ((nobj (make-vector (length obj) eieio-unbound)) 69 (let ((nobj (call-next-method)))
70 (nm (eieio--object-name obj))
71 (passname (and params (stringp (car params))))
72 (num 1))
73 (aset nobj 0 'object)
74 (setf (eieio--object-class nobj) (eieio--object-class obj))
75 ;; The following was copied from the default clone.
76 (if (not passname)
77 (save-match-data
78 (if (string-match "-\\([0-9]+\\)" nm)
79 (setq num (1+ (string-to-number (match-string 1 nm)))
80 nm (substring nm 0 (match-beginning 0))))
81 (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
82 (setf (eieio--object-name nobj) (car params)))
83 ;; Now initialize from params.
84 (if params (shared-initialize nobj (if passname (cdr params) params)))
85 (oset nobj parent-instance obj) 70 (oset nobj parent-instance obj)
86 nobj)) 71 nobj))
87 72
@@ -155,7 +140,7 @@ Multiple calls to `make-instance' will return this object."))
155A singleton is a class which will only ever have one instance." 140A singleton is a class which will only ever have one instance."
156 :abstract t) 141 :abstract t)
157 142
158(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots) 143(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots)
159 "Constructor for singleton CLASS. 144 "Constructor for singleton CLASS.
160NAME and SLOTS initialize the new object. 145NAME and SLOTS initialize the new object.
161This constructor guarantees that no matter how many you request, 146This constructor guarantees that no matter how many you request,
@@ -270,7 +255,7 @@ malicious code.
270Note: This function recurses when a slot of :type of some object is 255Note: This function recurses when a slot of :type of some object is
271identified, and needing more object creation." 256identified, and needing more object creation."
272 (let ((objclass (nth 0 inputlist)) 257 (let ((objclass (nth 0 inputlist))
273 (objname (nth 1 inputlist)) 258 ;; (objname (nth 1 inputlist))
274 (slots (nthcdr 2 inputlist)) 259 (slots (nthcdr 2 inputlist))
275 (createslots nil)) 260 (createslots nil))
276 261
@@ -285,7 +270,7 @@ identified, and needing more object creation."
285 ;; In addition, strip out quotes, list functions, and update 270 ;; In addition, strip out quotes, list functions, and update
286 ;; object constructors as needed. 271 ;; object constructors as needed.
287 (setq value (eieio-persistent-validate/fix-slot-value 272 (setq value (eieio-persistent-validate/fix-slot-value
288 objclass name value)) 273 (eieio--class-v objclass) name value))
289 274
290 (push name createslots) 275 (push name createslots)
291 (push value createslots) 276 (push value createslots)
@@ -293,7 +278,7 @@ identified, and needing more object creation."
293 278
294 (setq slots (cdr (cdr slots)))) 279 (setq slots (cdr (cdr slots))))
295 280
296 (apply 'make-instance objclass objname (nreverse createslots)) 281 (apply #'make-instance objclass (nreverse createslots))
297 282
298 ;;(eval inputlist) 283 ;;(eval inputlist)
299 )) 284 ))
@@ -305,11 +290,13 @@ constructor functions are considered valid.
305Second, any text properties will be stripped from strings." 290Second, any text properties will be stripped from strings."
306 (cond ((consp proposed-value) 291 (cond ((consp proposed-value)
307 ;; Lists with something in them need special treatment. 292 ;; Lists with something in them need special treatment.
308 (let ((slot-idx (eieio-slot-name-index class nil slot)) 293 (let ((slot-idx (eieio--slot-name-index class
294 nil slot))
309 (type nil) 295 (type nil)
310 (classtype nil)) 296 (classtype nil))
311 (setq slot-idx (- slot-idx 3)) 297 (setq slot-idx (- slot-idx
312 (setq type (aref (eieio--class-public-type (class-v class)) 298 (eval-when-compile eieio--object-num-slots)))
299 (setq type (aref (eieio--class-public-type class)
313 slot-idx)) 300 slot-idx))
314 301
315 (setq classtype (eieio-persistent-slot-type-is-class-p 302 (setq classtype (eieio-persistent-slot-type-is-class-p
@@ -346,8 +333,8 @@ Second, any text properties will be stripped from strings."
346 (unless (and 333 (unless (and
347 ;; Do we have a type? 334 ;; Do we have a type?
348 (consp classtype) (class-p (car classtype))) 335 (consp classtype) (class-p (car classtype)))
349 (error "In save file, list of object constructors found, but no :type specified for slot %S" 336 (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
350 slot)) 337 slot classtype))
351 338
352 ;; We have a predicate, but it doesn't satisfy the predicate? 339 ;; We have a predicate, but it doesn't satisfy the predicate?
353 (dolist (PV (cdr proposed-value)) 340 (dolist (PV (cdr proposed-value))
@@ -375,31 +362,49 @@ Second, any text properties will be stripped from strings."
375 ) 362 )
376 363
377(defun eieio-persistent-slot-type-is-class-p (type) 364(defun eieio-persistent-slot-type-is-class-p (type)
378 "Return the class refered to in TYPE. 365 "Return the class referred to in TYPE.
379If no class is referenced there, then return nil." 366If no class is referenced there, then return nil."
380 (cond ((class-p type) 367 (cond ((class-p type)
381 ;; If the type is a class, then return it. 368 ;; If the type is a class, then return it.
382 type) 369 type)
383 370 ((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
384 ((and (symbolp type) (string-match "-child$" (symbol-name type)) 371 ;; If it is the type of a list of a class, then return that class and
372 ;; the type.
373 (cons (cadr type) type))
374
375 ((and (symbolp type) (get type 'cl-deftype-handler))
376 ;; Macro-expand the type according to cl-deftype definitions.
377 (eieio-persistent-slot-type-is-class-p
378 (funcall (get type 'cl-deftype-handler))))
379
380 ;; FIXME: foo-child should not be a valid type!
381 ((and (symbolp type) (string-match "-child\\'" (symbol-name type))
385 (class-p (intern-soft (substring (symbol-name type) 0 382 (class-p (intern-soft (substring (symbol-name type) 0
386 (match-beginning 0))))) 383 (match-beginning 0)))))
384 (unless eieio-backward-compatibility
385 (error "Use of bogus %S type instead of %S"
386 type (intern-soft (substring (symbol-name type) 0
387 (match-beginning 0)))))
387 ;; If it is the predicate ending with -child, then return 388 ;; If it is the predicate ending with -child, then return
388 ;; that class. Unfortunately, in EIEIO, typep of just the 389 ;; that class. Unfortunately, in EIEIO, typep of just the
389 ;; class is the same as if we used -child, so no further work needed. 390 ;; class is the same as if we used -child, so no further work needed.
390 (intern-soft (substring (symbol-name type) 0 391 (intern-soft (substring (symbol-name type) 0
391 (match-beginning 0)))) 392 (match-beginning 0))))
392 393 ;; FIXME: foo-list should not be a valid type!
393 ((and (symbolp type) (string-match "-list$" (symbol-name type)) 394 ((and (symbolp type) (string-match "-list\\'" (symbol-name type))
394 (class-p (intern-soft (substring (symbol-name type) 0 395 (class-p (intern-soft (substring (symbol-name type) 0
395 (match-beginning 0))))) 396 (match-beginning 0)))))
397 (unless eieio-backward-compatibility
398 (error "Use of bogus %S type instead of (list-of %S)"
399 type (intern-soft (substring (symbol-name type) 0
400 (match-beginning 0)))))
396 ;; If it is the predicate ending with -list, then return 401 ;; If it is the predicate ending with -list, then return
397 ;; that class and the predicate to use. 402 ;; that class and the predicate to use.
398 (cons (intern-soft (substring (symbol-name type) 0 403 (cons (intern-soft (substring (symbol-name type) 0
399 (match-beginning 0))) 404 (match-beginning 0)))
400 type)) 405 type))
401 406
402 ((and (consp type) (eq (car type) 'or)) 407 ((eq (car-safe type) 'or)
403 ;; If type is a list, and is an or, it is possibly something 408 ;; If type is a list, and is an or, it is possibly something
404 ;; like (or null myclass), so check for that. 409 ;; like (or null myclass), so check for that.
405 (let ((ans nil)) 410 (let ((ans nil))
@@ -463,34 +468,38 @@ instance."
463 468
464 469
465;;; Named object 470;;; Named object
466;;
467;; Named objects use the objects `name' as a slot, and that slot
468;; is accessed with the `object-name' symbol.
469 471
470(defclass eieio-named () 472(defclass eieio-named ()
471 () 473 ((object-name :initarg :object-name :initform nil))
472 "Object with a name. 474 "Object with a name."
473Name storage already occurs in an object. This object provides get/set
474access to it."
475 :abstract t) 475 :abstract t)
476 476
477(defmethod slot-missing ((obj eieio-named) 477(defmethod eieio-object-name-string ((obj eieio-named))
478 slot-name operation &optional new-value) 478 "Return a string which is OBJ's name."
479 "Called when a non-existent slot is accessed. 479 (or (slot-value obj 'object-name)
480For variable `eieio-named', provide an imaginary `object-name' slot. 480 (symbol-name (eieio-object-class obj))))
481Argument OBJ is the named object. 481
482Argument SLOT-NAME is the slot that was attempted to be accessed. 482(defmethod eieio-object-set-name-string ((obj eieio-named) name)
483OPERATION is the type of access, such as `oref' or `oset'. 483 "Set the string which is OBJ's NAME."
484NEW-VALUE is the value that was being set into SLOT if OPERATION were 484 (eieio--check-type stringp name)
485a set type." 485 (eieio-oset obj 'object-name name))
486 (if (memq slot-name '(object-name :object-name)) 486
487 (cond ((eq operation 'oset) 487(defmethod clone ((obj eieio-named) &rest params)
488 (if (not (stringp new-value)) 488 "Clone OBJ, initializing `:parent' to OBJ.
489 (signal 'invalid-slot-type 489All slots are unbound, except those initialized with PARAMS."
490 (list obj slot-name 'string new-value))) 490 (let* ((newname (and (stringp (car params)) (pop params)))
491 (eieio-object-set-name-string obj new-value)) 491 (nobj (apply #'call-next-method obj params))
492 (t (eieio-object-name-string obj))) 492 (nm (slot-value obj 'object-name)))
493 (call-next-method))) 493 (eieio-oset obj 'object-name
494 (or newname
495 (save-match-data
496 (if (and nm (string-match "-\\([0-9]+\\)" nm))
497 (let ((num (1+ (string-to-number
498 (match-string 1 nm)))))
499 (concat (substring nm 0 (match-beginning 0))
500 "-" (int-to-string num)))
501 (concat nm "-1")))))
502 nobj))
494 503
495(provide 'eieio-base) 504(provide 'eieio-base)
496 505
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 68b376592f5..dc2c873eb42 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -32,6 +32,7 @@
32;;; Code: 32;;; Code:
33 33
34(require 'cl-lib) 34(require 'cl-lib)
35(require 'pcase)
35 36
36(put 'eieio--defalias 'byte-hunk-handler 37(put 'eieio--defalias 'byte-hunk-handler
37 #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) 38 #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
@@ -39,6 +40,9 @@
39 "Like `defalias', but with less side-effects. 40 "Like `defalias', but with less side-effects.
40More specifically, it has no side-effects at all when the new function 41More specifically, it has no side-effects at all when the new function
41definition is the same (`eq') as the old one." 42definition is the same (`eq') as the old one."
43 (while (and (fboundp name) (symbolp (symbol-function name)))
44 ;; Follow aliases, so methods applied to obsolete aliases still work.
45 (setq name (symbol-function name)))
42 (unless (and (fboundp name) 46 (unless (and (fboundp name)
43 (eq (symbol-function name) body)) 47 (eq (symbol-function name) body))
44 (defalias name body))) 48 (defalias name body)))
@@ -74,6 +78,13 @@ default setting for optimization purposes.")
74(defvar eieio-initializing-object nil 78(defvar eieio-initializing-object nil
75 "Set to non-nil while initializing an object.") 79 "Set to non-nil while initializing an object.")
76 80
81(defvar eieio-backward-compatibility t
82 "If nil, drop support for some behaviors of older versions of EIEIO.
83Currently under control of this var:
84- Define every class as a var whose value is the class symbol.
85- Define <class>-child-p and <class>-list-p predicates.
86- Allow object names in constructors.")
87
77(defconst eieio-unbound 88(defconst eieio-unbound
78 (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) 89 (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound))
79 eieio-unbound 90 eieio-unbound
@@ -98,96 +109,87 @@ default setting for optimization purposes.")
98 "A stack of the classes currently in scope during method invocation.") 109 "A stack of the classes currently in scope during method invocation.")
99 110
100(defun eieio--scoped-class () 111(defun eieio--scoped-class ()
101 "Return the class currently in scope, or nil." 112 "Return the class object currently in scope, or nil."
102 (car-safe eieio--scoped-class-stack)) 113 (car-safe eieio--scoped-class-stack))
103 114
104(defmacro eieio--with-scoped-class (class &rest forms) 115(defmacro eieio--with-scoped-class (class &rest forms)
105 "Set CLASS as the currently scoped class while executing FORMS." 116 "Set CLASS as the currently scoped class while executing FORMS."
106 (declare (indent 1)) 117 (declare (indent 1))
107 `(unwind-protect 118 `(let ((eieio--scoped-class-stack (cons ,class eieio--scoped-class-stack)))
108 (progn 119 ,@forms))
109 (push ,class eieio--scoped-class-stack) 120
110 ,@forms) 121(progn
111 (pop eieio--scoped-class-stack))) 122 ;; Arrange for field access not to bother checking if the access is indeed
123 ;; made to an eieio--class object.
124 (cl-declaim (optimize (safety 0)))
125(cl-defstruct (eieio--class
126 (:constructor nil)
127 (:constructor eieio--class-make (symbol &aux (tag 'defclass)))
128 (:type vector)
129 (:copier nil))
130 ;; We use an untagged cl-struct, with our own hand-made tag as first field
131 ;; (containing the symbol `defclass'). It would be better to use a normal
132 ;; cl-struct with its normal tag (e.g. so that cl-defstruct can define the
133 ;; predicate for us), but that breaks compatibility with .elc files compiled
134 ;; against older versions of EIEIO.
135 tag
136 symbol ;; symbol (self-referencing)
137 parent children
138 symbol-hashtable ;; hashtable permitting fast access to variable position indexes
139 ;; @todo
140 ;; the word "public" here is leftovers from the very first version.
141 ;; Get rid of it!
142 public-a ;; class attribute index
143 public-d ;; class attribute defaults index
144 public-doc ;; class documentation strings for attributes
145 public-type ;; class type for a slot
146 public-custom ;; class custom type for a slot
147 public-custom-label ;; class custom group for a slot
148 public-custom-group ;; class custom group for a slot
149 public-printer ;; printer for a slot
150 protection ;; protection for a slot
151 initarg-tuples ;; initarg tuples list
152 class-allocation-a ;; class allocated attributes
153 class-allocation-doc ;; class allocated documentation
154 class-allocation-type ;; class allocated value type
155 class-allocation-custom ;; class allocated custom descriptor
156 class-allocation-custom-label ;; class allocated custom descriptor
157 class-allocation-custom-group ;; class allocated custom group
158 class-allocation-printer ;; class allocated printer for a slot
159 class-allocation-protection ;; class allocated protection list
160 class-allocation-values ;; class allocated value vector
161 default-object-cache ;; what a newly created object would look like.
162 ; This will speed up instantiation time as
163 ; only a `copy-sequence' will be needed, instead of
164 ; looping over all the values and setting them from
165 ; the default.
166 options ;; storage location of tagged class option
167 ; Stored outright without modifications or stripping
168 )
169 ;; Set it back to the default value.
170 (cl-declaim (optimize (safety 1))))
112 171
113;;; 172
114;; Field Accessors 173(cl-defstruct (eieio--object
115;; 174 (:type vector) ;We manage our own tagging system.
116(defmacro eieio--define-field-accessors (prefix fields) 175 (:constructor nil)
117 (declare (indent 1)) 176 (:copier nil))
118 (let ((index 0) 177 ;; `class-tag' holds a symbol, which is not the class name, but is instead
119 (defs '())) 178 ;; properly prefixed as an internal EIEIO thingy and which holds the class
120 (dolist (field fields) 179 ;; object/struct in its `symbol-value' slot.
121 (let ((doc (if (listp field) 180 class-tag)
122 (prog1 (cadr field) (setq field (car field)))))) 181
123 (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) 182(eval-and-compile
124 ,@(if doc (list (format (if (string-match "\n" doc) 183 (defconst eieio--object-num-slots
125 "Return %s" "Return %s of a %s.") 184 (length (get 'eieio--object 'cl-struct-slots))))
126 doc prefix))) 185
127 (list 'aref x ,index)) 186(defsubst eieio--object-class-object (obj)
128 defs) 187 (symbol-value (eieio--object-class-tag obj)))
129 (setq index (1+ index)))) 188
130 `(eval-and-compile 189(defsubst eieio--object-class-name (obj)
131 ,@(nreverse defs) 190 ;; FIXME: Most uses of this function should be changed to use
132 (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) 191 ;; eieio--object-class-object instead!
133 192 (eieio--class-symbol (eieio--object-class-object obj)))
134(eieio--define-field-accessors class
135 (-unused-0 ;;FIXME: not sure, but at least there was no accessor!
136 (symbol "symbol (self-referencing)")
137 parent children
138 (symbol-obarray "obarray permitting fast access to variable position indexes")
139 ;; @todo
140 ;; the word "public" here is leftovers from the very first version.
141 ;; Get rid of it!
142 (public-a "class attribute index")
143 (public-d "class attribute defaults index")
144 (public-doc "class documentation strings for attributes")
145 (public-type "class type for a slot")
146 (public-custom "class custom type for a slot")
147 (public-custom-label "class custom group for a slot")
148 (public-custom-group "class custom group for a slot")
149 (public-printer "printer for a slot")
150 (protection "protection for a slot")
151 (initarg-tuples "initarg tuples list")
152 (class-allocation-a "class allocated attributes")
153 (class-allocation-doc "class allocated documentation")
154 (class-allocation-type "class allocated value type")
155 (class-allocation-custom "class allocated custom descriptor")
156 (class-allocation-custom-label "class allocated custom descriptor")
157 (class-allocation-custom-group "class allocated custom group")
158 (class-allocation-printer "class allocated printer for a slot")
159 (class-allocation-protection "class allocated protection list")
160 (class-allocation-values "class allocated value vector")
161 (default-object-cache "what a newly created object would look like.
162This will speed up instantiation time as only a `copy-sequence' will
163be needed, instead of looping over all the values and setting them
164from the default.")
165 (options "storage location of tagged class options.
166Stored outright without modifications or stripping.")))
167
168(eieio--define-field-accessors object
169 (-unused-0 ;;FIXME: not sure, but at least there was no accessor!
170 (class "class struct defining OBJ")
171 name))
172
173;; FIXME: The constants below should have an `eieio-' prefix added!!
174
175(defconst method-static 0 "Index into :static tag on a method.")
176(defconst method-before 1 "Index into :before tag on a method.")
177(defconst method-primary 2 "Index into :primary tag on a method.")
178(defconst method-after 3 "Index into :after tag on a method.")
179(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.")
180(defconst method-generic-before 4 "Index into generic :before tag on a method.")
181(defconst method-generic-primary 5 "Index into generic :primary tag on a method.")
182(defconst method-generic-after 6 "Index into generic :after tag on a method.")
183(defconst method-num-slots 7 "Number of indexes into a method's vector.")
184
185(defsubst eieio-specialized-key-to-generic-key (key)
186 "Convert a specialized KEY into a generic method key."
187 (cond ((eq key method-static) 0) ;; don't convert
188 ((< key method-num-lists) (+ key 3)) ;; The conversion
189 (t key) ;; already generic.. maybe.
190 ))
191 193
192 194
193;;; Important macros used internally in eieio. 195;;; Important macros used internally in eieio.
@@ -201,114 +203,91 @@ Stored outright without modifications or stripping.")))
201 (t `(,type ,obj)))) 203 (t `(,type ,obj))))
202 (signal 'wrong-type-argument (list ',type ,obj)))) 204 (signal 'wrong-type-argument (list ',type ,obj))))
203 205
204(defmacro class-v (class) 206(defmacro eieio--class-v (class) ;Use a macro, so it acts as a GV place.
205 "Internal: Return the class vector from the CLASS symbol." 207 "Internal: Return the class vector from the CLASS symbol."
208 (declare (debug t))
206 ;; No check: If eieio gets this far, it has probably been checked already. 209 ;; No check: If eieio gets this far, it has probably been checked already.
207 `(get ,class 'eieio-class-definition)) 210 `(get ,class 'eieio-class-definition))
208 211
212(defsubst eieio--class-object (class)
213 "Return the class object."
214 (if (symbolp class)
215 ;; Keep the symbol if class-v is nil, for better error messages.
216 (or (eieio--class-v class) class)
217 class))
218
219(defsubst eieio--class-p (class)
220 "Return non-nil if CLASS is a valid class object."
221 (condition-case nil
222 (eq (aref class 0) 'defclass)
223 (error nil)))
224
225(defsubst eieio-class-object (class)
226 "Check that CLASS is a class and return the corresponding object."
227 (let ((c (eieio--class-object class)))
228 (eieio--check-type eieio--class-p c)
229 c))
230
209(defsubst class-p (class) 231(defsubst class-p (class)
210 "Return non-nil if CLASS is a valid class vector. 232 "Return non-nil if CLASS is a valid class vector.
211CLASS is a symbol." 233CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
212 ;; this new method is faster since it doesn't waste time checking lots of 234 ;; this new method is faster since it doesn't waste time checking lots of
213 ;; things. 235 ;; things.
214 (condition-case nil 236 (condition-case nil
215 (eq (aref (class-v class) 0) 'defclass) 237 (eq (aref (eieio--class-v class) 0) 'defclass)
216 (error nil))) 238 (error nil)))
217 239
218(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." 240(defun eieio-class-name (class)
241 "Return a Lisp like symbol name for CLASS."
242 ;; FIXME: What's a "Lisp like symbol name"?
243 ;; FIXME: CLOS returns a symbol, but the code returns a string.
244 (if (eieio--class-p class) (setq class (eieio--class-symbol class)))
219 (eieio--check-type class-p class) 245 (eieio--check-type class-p class)
220 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, 246 ;; I think this is supposed to return a symbol, but to me CLASS is a symbol,
221 ;; and I wanted a string. Arg! 247 ;; and I wanted a string. Arg!
222 (format "#<class %s>" (symbol-name class))) 248 (format "#<class %s>" (symbol-name class)))
223(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") 249(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
224 250
225(defmacro eieio-class-parents-fast (class)
226 "Return parent classes to CLASS with no check."
227 `(eieio--class-parent (class-v ,class)))
228
229(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check."
230 `(eieio--class-children (class-v ,class)))
231
232(defmacro same-class-fast-p (obj class)
233 "Return t if OBJ is of class-type CLASS with no error checking."
234 `(eq (eieio--object-class ,obj) ,class))
235
236(defmacro class-constructor (class) 251(defmacro class-constructor (class)
237 "Return the symbol representing the constructor of CLASS." 252 "Return the symbol representing the constructor of CLASS."
238 `(eieio--class-symbol (class-v ,class))) 253 (declare (debug t))
239 254 `(eieio--class-symbol (eieio--class-v ,class)))
240(defsubst generic-p (method) 255
241 "Return non-nil if symbol METHOD is a generic function. 256(defmacro eieio--class-option-assoc (list option)
242Only methods have the symbol `eieio-method-obarray' as a property
243\(which contains a list of all bindings to that method type.)"
244 (and (fboundp method) (get method 'eieio-method-obarray)))
245
246(defun generic-primary-only-p (method)
247 "Return t if symbol METHOD is a generic function with only primary methods.
248Only methods have the symbol `eieio-method-obarray' as a property (which
249contains a list of all bindings to that method type.)
250Methods with only primary implementations are executed in an optimized way."
251 (and (generic-p method)
252 (let ((M (get method 'eieio-method-tree)))
253 (and (< 0 (length (aref M method-primary)))
254 (not (aref M method-static))
255 (not (aref M method-before))
256 (not (aref M method-after))
257 (not (aref M method-generic-before))
258 (not (aref M method-generic-primary))
259 (not (aref M method-generic-after))))
260 ))
261
262(defun generic-primary-only-one-p (method)
263 "Return t if symbol METHOD is a generic function with only primary methods.
264Only methods have the symbol `eieio-method-obarray' as a property (which
265contains a list of all bindings to that method type.)
266Methods with only primary implementations are executed in an optimized way."
267 (and (generic-p method)
268 (let ((M (get method 'eieio-method-tree)))
269 (and (= 1 (length (aref M method-primary)))
270 (not (aref M method-static))
271 (not (aref M method-before))
272 (not (aref M method-after))
273 (not (aref M method-generic-before))
274 (not (aref M method-generic-primary))
275 (not (aref M method-generic-after))))
276 ))
277
278(defmacro class-option-assoc (list option)
279 "Return from LIST the found OPTION, or nil if it doesn't exist." 257 "Return from LIST the found OPTION, or nil if it doesn't exist."
280 `(car-safe (cdr (memq ,option ,list)))) 258 `(car-safe (cdr (memq ,option ,list))))
281 259
282(defmacro class-option (class option) 260(defsubst eieio--class-option (class option)
283 "Return the value stored for CLASS' OPTION. 261 "Return the value stored for CLASS' OPTION.
284Return nil if that option doesn't exist." 262Return nil if that option doesn't exist."
285 `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) 263 (eieio--class-option-assoc (eieio--class-options class) option))
286 264
287(defsubst eieio-object-p (obj) 265(defsubst eieio-object-p (obj)
288 "Return non-nil if OBJ is an EIEIO object." 266 "Return non-nil if OBJ is an EIEIO object."
289 (condition-case nil 267 (and (arrayp obj)
290 (and (eq (aref obj 0) 'object) 268 (condition-case nil
291 (class-p (eieio--object-class obj))) 269 (eq (aref (eieio--object-class-object obj) 0) 'defclass)
292 (error nil))) 270 (error nil))))
271
293(defalias 'object-p 'eieio-object-p) 272(defalias 'object-p 'eieio-object-p)
294 273
295(defsubst class-abstract-p (class) 274(defsubst class-abstract-p (class)
296 "Return non-nil if CLASS is abstract. 275 "Return non-nil if CLASS is abstract.
297Abstract classes cannot be instantiated." 276Abstract classes cannot be instantiated."
298 (class-option class :abstract)) 277 (eieio--class-option (eieio--class-v class) :abstract))
299 278
300(defmacro class-method-invocation-order (class) 279(defsubst eieio--class-method-invocation-order (class)
301 "Return the invocation order of CLASS. 280 "Return the invocation order of CLASS.
302Abstract classes cannot be instantiated." 281Abstract classes cannot be instantiated."
303 `(or (class-option ,class :method-invocation-order) 282 (or (eieio--class-option class :method-invocation-order)
304 :breadth-first)) 283 :breadth-first))
305 284
306 285
307 286
308;;; 287;;;
309;; Class Creation 288;; Class Creation
310 289
311(defvar eieio-defclass-autoload-map (make-vector 7 nil) 290(defvar eieio-defclass-autoload-map (make-hash-table)
312 "Symbol map of superclasses we find in autoloads.") 291 "Symbol map of superclasses we find in autoloads.")
313 292
314;; We autoload this because it's used in `make-autoload'. 293;; We autoload this because it's used in `make-autoload'.
@@ -322,16 +301,12 @@ SUPERCLASSES as children.
322It creates an autoload function for CNAME's constructor." 301It creates an autoload function for CNAME's constructor."
323 ;; Assume we've already debugged inputs. 302 ;; Assume we've already debugged inputs.
324 303
325 (let* ((oldc (when (class-p cname) (class-v cname))) 304 (let* ((oldc (when (class-p cname) (eieio--class-v cname)))
326 (newc (make-vector eieio--class-num-slots nil)) 305 (newc (eieio--class-make cname))
327 ) 306 )
328 (if oldc 307 (if oldc
329 nil ;; Do nothing if we already have this class. 308 nil ;; Do nothing if we already have this class.
330 309
331 ;; Create the class in NEWC, but don't fill anything else in.
332 (aset newc 0 'defclass)
333 (setf (eieio--class-symbol newc) cname)
334
335 (let ((clear-parent nil)) 310 (let ((clear-parent nil))
336 ;; No parents? 311 ;; No parents?
337 (when (not superclasses) 312 (when (not superclasses)
@@ -348,34 +323,25 @@ It creates an autoload function for CNAME's constructor."
348 ;; map needs to be cleared! 323 ;; map needs to be cleared!
349 324
350 325
351 ;; Does our parent exist? 326 ;; Save the child in the parent.
352 (if (not (class-p SC)) 327 (cl-pushnew cname (if (class-p SC)
353 328 (eieio--class-children (eieio--class-v SC))
354 ;; Create a symbol for this parent, and then store this 329 ;; Parent doesn't exist yet.
355 ;; parent on that symbol. 330 (gethash SC eieio-defclass-autoload-map)))
356 (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map)))
357 (if (not (boundp sym))
358 (set sym (list cname))
359 (add-to-list sym cname))
360 )
361 331
362 ;; We have a parent, save the child in there. 332 ;; Save parent in child.
363 (when (not (member cname (eieio--class-children (class-v SC)))) 333 (push (eieio--class-v SC) (eieio--class-parent newc)))
364 (setf (eieio--class-children (class-v SC))
365 (cons cname (eieio--class-children (class-v SC))))))
366
367 ;; save parent in child
368 (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc)))
369 )
370 334
371 ;; turn this into a usable self-pointing symbol 335 ;; turn this into a usable self-pointing symbol
372 (set cname cname) 336 (when eieio-backward-compatibility
337 (set cname cname)
338 (make-obsolete-variable cname (format "use '%s instead" cname) "25.1"))
373 339
374 ;; Store the new class vector definition into the symbol. We need to 340 ;; Store the new class vector definition into the symbol. We need to
375 ;; do this first so that we can call defmethod for the accessor. 341 ;; do this first so that we can call defmethod for the accessor.
376 ;; The vector will be updated by the following while loop and will not 342 ;; The vector will be updated by the following while loop and will not
377 ;; need to be stored a second time. 343 ;; need to be stored a second time.
378 (put cname 'eieio-class-definition newc) 344 (setf (eieio--class-v cname) newc)
379 345
380 ;; Clear the parent 346 ;; Clear the parent
381 (if clear-parent (setf (eieio--class-parent newc) nil)) 347 (if clear-parent (setf (eieio--class-parent newc) nil))
@@ -390,8 +356,7 @@ It creates an autoload function for CNAME's constructor."
390 356
391(defsubst eieio-class-un-autoload (cname) 357(defsubst eieio-class-un-autoload (cname)
392 "If class CNAME is in an autoload state, load its file." 358 "If class CNAME is in an autoload state, load its file."
393 (when (eq (car-safe (symbol-function cname)) 'autoload) 359 (autoload-do-load (symbol-function cname))) ; cname
394 (load-library (car (cdr (symbol-function cname))))))
395 360
396(cl-deftype list-of (elem-type) 361(cl-deftype list-of (elem-type)
397 `(and list 362 `(and list
@@ -399,11 +364,12 @@ It creates an autoload function for CNAME's constructor."
399 (cl-every (lambda (elem) (cl-typep elem ',elem-type)) 364 (cl-every (lambda (elem) (cl-typep elem ',elem-type))
400 list))))) 365 list)))))
401 366
402(defun eieio-defclass (cname superclasses slots options-and-doc) 367(declare-function eieio--defmethod "eieio-generic" (method kind argclass code))
403 ;; FIXME: Most of this should be moved to the `defclass' macro. 368
369(defun eieio-defclass-internal (cname superclasses slots options)
404 "Define CNAME as a new subclass of SUPERCLASSES. 370 "Define CNAME as a new subclass of SUPERCLASSES.
405SLOTS are the slots residing in that class definition, and options or 371SLOTS are the slots residing in that class definition, and OPTIONS
406documentation OPTIONS-AND-DOC is the toplevel documentation for this class. 372holds the class options.
407See `defclass' for more information." 373See `defclass' for more information."
408 ;; Run our eieio-hook each time, and clear it when we are done. 374 ;; Run our eieio-hook each time, and clear it when we are done.
409 ;; This way people can add hooks safely if they want to modify eieio 375 ;; This way people can add hooks safely if they want to modify eieio
@@ -411,18 +377,12 @@ See `defclass' for more information."
411 (run-hooks 'eieio-hook) 377 (run-hooks 'eieio-hook)
412 (setq eieio-hook nil) 378 (setq eieio-hook nil)
413 379
414 (eieio--check-type listp superclasses)
415
416 (let* ((pname superclasses) 380 (let* ((pname superclasses)
417 (newc (make-vector eieio--class-num-slots nil)) 381 (newc (eieio--class-make cname))
418 (oldc (when (class-p cname) (class-v cname))) 382 (oldc (when (class-p cname) (eieio--class-v cname)))
419 (groups nil) ;; list of groups id'd from slots 383 (groups nil) ;; list of groups id'd from slots
420 (options nil)
421 (clearparent nil)) 384 (clearparent nil))
422 385
423 (aset newc 0 'defclass)
424 (setf (eieio--class-symbol newc) cname)
425
426 ;; If this class already existed, and we are updating its structure, 386 ;; If this class already existed, and we are updating its structure,
427 ;; make sure we keep the old child list. This can cause bugs, but 387 ;; make sure we keep the old child list. This can cause bugs, but
428 ;; if no new slots are created, it also saves time, and prevents 388 ;; if no new slots are created, it also saves time, and prevents
@@ -430,123 +390,68 @@ See `defclass' for more information."
430 ;; byte compiling an EIEIO file. 390 ;; byte compiling an EIEIO file.
431 (if oldc 391 (if oldc
432 (setf (eieio--class-children newc) (eieio--class-children oldc)) 392 (setf (eieio--class-children newc) (eieio--class-children oldc))
433 ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. 393 ;; If the old class did not exist, but did exist in the autoload map,
434 ;; This is like the above, but deals with autoloads nicely. 394 ;; then adopt those children. This is like the above, but deals with
435 (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) 395 ;; autoloads nicely.
436 (when sym 396 (let ((children (gethash cname eieio-defclass-autoload-map)))
437 (condition-case nil 397 (when children
438 (setf (eieio--class-children newc) (symbol-value sym)) 398 (setf (eieio--class-children newc) children)
439 (error nil)) 399 (remhash cname eieio-defclass-autoload-map))))
440 (unintern (symbol-name cname) eieio-defclass-autoload-map)
441 ))
442 )
443
444 (cond ((and (stringp (car options-and-doc))
445 (/= 1 (% (length options-and-doc) 2)))
446 (error "Too many arguments to `defclass'"))
447 ((and (symbolp (car options-and-doc))
448 (/= 0 (% (length options-and-doc) 2)))
449 (error "Too many arguments to `defclass'"))
450 )
451
452 (setq options
453 (if (stringp (car options-and-doc))
454 (cons :documentation options-and-doc)
455 options-and-doc))
456 400
457 (if pname 401 (if pname
458 (progn 402 (progn
459 (while pname 403 (dolist (p pname)
460 (if (and (car pname) (symbolp (car pname))) 404 (if (and p (symbolp p))
461 (if (not (class-p (car pname))) 405 (if (not (class-p p))
462 ;; bad class 406 ;; bad class
463 (error "Given parent class %s is not a class" (car pname)) 407 (error "Given parent class %S is not a class" p)
464 ;; good parent class... 408 ;; good parent class...
465 ;; save new child in parent 409 ;; save new child in parent
466 (when (not (member cname (eieio--class-children (class-v (car pname))))) 410 (cl-pushnew cname (eieio--class-children (eieio--class-v p)))
467 (setf (eieio--class-children (class-v (car pname)))
468 (cons cname (eieio--class-children (class-v (car pname))))))
469 ;; Get custom groups, and store them into our local copy. 411 ;; Get custom groups, and store them into our local copy.
470 (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) 412 (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
471 (class-option (car pname) :custom-groups)) 413 (eieio--class-option (eieio--class-v p) :custom-groups))
472 ;; save parent in child 414 ;; save parent in child
473 (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) 415 (push (eieio--class-v p) (eieio--class-parent newc)))
474 (error "Invalid parent class %s" pname)) 416 (error "Invalid parent class %S" p)))
475 (setq pname (cdr pname)))
476 ;; Reverse the list of our parents so that they are prioritized in 417 ;; Reverse the list of our parents so that they are prioritized in
477 ;; the same order as specified in the code. 418 ;; the same order as specified in the code.
478 (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) 419 (cl-callf nreverse (eieio--class-parent newc)))
479 ;; If there is nothing to loop over, then inherit from the 420 ;; If there is nothing to loop over, then inherit from the
480 ;; default superclass. 421 ;; default superclass.
481 (unless (eq cname 'eieio-default-superclass) 422 (unless (eq cname 'eieio-default-superclass)
482 ;; adopt the default parent here, but clear it later... 423 ;; adopt the default parent here, but clear it later...
483 (setq clearparent t) 424 (setq clearparent t)
484 ;; save new child in parent 425 ;; save new child in parent
485 (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) 426 (cl-pushnew cname (eieio--class-children eieio-default-superclass))
486 (setf (eieio--class-children (class-v 'eieio-default-superclass)) 427 ;; save parent in child
487 (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) 428 (setf (eieio--class-parent newc) (list eieio-default-superclass))))
488 ;; save parent in child
489 (setf (eieio--class-parent newc) (list eieio-default-superclass))))
490
491 ;; turn this into a usable self-pointing symbol
492 (set cname cname)
493
494 ;; These two tests must be created right away so we can have self-
495 ;; referencing classes. ei, a class whose slot can contain only
496 ;; pointers to itself.
497
498 ;; Create the test function
499 (let ((csym (intern (concat (symbol-name cname) "-p"))))
500 (fset csym
501 (list 'lambda (list 'obj)
502 (format "Test OBJ to see if it an object of type %s" cname)
503 (list 'and '(eieio-object-p obj)
504 (list 'same-class-p 'obj cname)))))
505
506 ;; Make sure the method invocation order is a valid value.
507 (let ((io (class-option-assoc options :method-invocation-order)))
508 (when (and io (not (member io '(:depth-first :breadth-first :c3))))
509 (error "Method invocation order %s is not allowed" io)
510 ))
511 429
512 ;; Create a handy child test too 430 ;; turn this into a usable self-pointing symbol; FIXME: Why?
513 (let ((csym (intern (concat (symbol-name cname) "-child-p")))) 431 (when eieio-backward-compatibility
514 (fset csym 432 (set cname cname)
515 `(lambda (obj) 433 (make-obsolete-variable cname (format "use '%s instead" cname) "25.1"))
516 ,(format
517 "Test OBJ to see if it an object is a child of type %s"
518 cname)
519 (and (eieio-object-p obj)
520 (object-of-class-p obj ,cname))))
521 434
522 ;; Create a handy list of the class test too 435 ;; Create a handy list of the class test too
523 (let ((csym (intern (concat (symbol-name cname) "-list-p")))) 436 (when eieio-backward-compatibility
524 (fset csym 437 (let ((csym (intern (concat (symbol-name cname) "-list-p"))))
525 `(lambda (obj) 438 (defalias csym
526 ,(format 439 `(lambda (obj)
527 "Test OBJ to see if it a list of objects which are a child of type %s" 440 ,(format
528 cname) 441 "Test OBJ to see if it a list of objects which are a child of type %s"
529 (when (listp obj) 442 cname)
530 (let ((ans t)) ;; nil is valid 443 (when (listp obj)
531 ;; Loop over all the elements of the input list, test 444 (let ((ans t)) ;; nil is valid
532 ;; each to make sure it is a child of the desired object class. 445 ;; Loop over all the elements of the input list, test
533 (while (and obj ans) 446 ;; each to make sure it is a child of the desired object class.
534 (setq ans (and (eieio-object-p (car obj)) 447 (while (and obj ans)
535 (object-of-class-p (car obj) ,cname))) 448 (setq ans (and (eieio-object-p (car obj))
536 (setq obj (cdr obj))) 449 (object-of-class-p (car obj) ,cname)))
537 ans))))) 450 (setq obj (cdr obj)))
538 451 ans))))
539 ;; When using typep, (typep OBJ 'myclass) returns t for objects which 452 (make-obsolete csym (format "use (cl-typep ... '(list-of %s)) instead"
540 ;; are subclasses of myclass. For our predicates, however, it is 453 cname)
541 ;; important for EIEIO to be backwards compatible, where 454 "25.1")))
542 ;; myobject-p, and myobject-child-p are different.
543 ;; "cl" uses this technique to specify symbols with specific typep
544 ;; test, so we can let typep have the CLOS documented behavior
545 ;; while keeping our above predicate clean.
546
547 ;; FIXME: It would be cleaner to use `cl-deftype' here.
548 (put cname 'cl-deftype-handler
549 (list 'lambda () `(list 'satisfies (quote ,csym)))))
550 455
551 ;; Before adding new slots, let's add all the methods and classes 456 ;; Before adding new slots, let's add all the methods and classes
552 ;; in from the parent class. 457 ;; in from the parent class.
@@ -556,78 +461,45 @@ See `defclass' for more information."
556 ;; do this first so that we can call defmethod for the accessor. 461 ;; do this first so that we can call defmethod for the accessor.
557 ;; The vector will be updated by the following while loop and will not 462 ;; The vector will be updated by the following while loop and will not
558 ;; need to be stored a second time. 463 ;; need to be stored a second time.
559 (put cname 'eieio-class-definition newc) 464 (setf (eieio--class-v cname) newc)
560 465
561 ;; Query each slot in the declaration list and mangle into the 466 ;; Query each slot in the declaration list and mangle into the
562 ;; class structure I have defined. 467 ;; class structure I have defined.
563 (while slots 468 (pcase-dolist (`(,name . ,slot) slots)
564 (let* ((slot1 (car slots)) 469 (let* ((init (or (plist-get slot :initform)
565 (name (car slot1)) 470 (if (member :initform slot) nil
566 (slot (cdr slot1))
567 (acces (plist-get slot ':accessor))
568 (init (or (plist-get slot ':initform)
569 (if (member ':initform slot) nil
570 eieio-unbound))) 471 eieio-unbound)))
571 (initarg (plist-get slot ':initarg)) 472 (initarg (plist-get slot :initarg))
572 (docstr (plist-get slot ':documentation)) 473 (docstr (plist-get slot :documentation))
573 (prot (plist-get slot ':protection)) 474 (prot (plist-get slot :protection))
574 (reader (plist-get slot ':reader)) 475 (alloc (plist-get slot :allocation))
575 (writer (plist-get slot ':writer)) 476 (type (plist-get slot :type))
576 (alloc (plist-get slot ':allocation)) 477 (custom (plist-get slot :custom))
577 (type (plist-get slot ':type)) 478 (label (plist-get slot :label))
578 (custom (plist-get slot ':custom)) 479 (customg (plist-get slot :group))
579 (label (plist-get slot ':label)) 480 (printer (plist-get slot :printer))
580 (customg (plist-get slot ':group)) 481
581 (printer (plist-get slot ':printer)) 482 (skip-nil (eieio--class-option-assoc options :allow-nil-initform))
582
583 (skip-nil (class-option-assoc options :allow-nil-initform))
584 ) 483 )
585 484
586 (if eieio-error-unsupported-class-tags
587 (let ((tmp slot))
588 (while tmp
589 (if (not (member (car tmp) '(:accessor
590 :initform
591 :initarg
592 :documentation
593 :protection
594 :reader
595 :writer
596 :allocation
597 :type
598 :custom
599 :label
600 :group
601 :printer
602 :allow-nil-initform
603 :custom-groups)))
604 (signal 'invalid-slot-type (list (car tmp))))
605 (setq tmp (cdr (cdr tmp))))))
606
607 ;; Clean up the meaning of protection. 485 ;; Clean up the meaning of protection.
608 (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) 486 (setq prot
609 ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) 487 (pcase prot
610 ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) 488 ((or 'nil 'public ':public) nil)
611 ((eq prot nil) nil) 489 ((or 'protected ':protected) 'protected)
612 (t (signal 'invalid-slot-type (list ':protection prot)))) 490 ((or 'private ':private) 'private)
613 491 (_ (signal 'invalid-slot-type (list :protection prot)))))
614 ;; Make sure the :allocation parameter has a valid value.
615 (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance)))
616 (signal 'invalid-slot-type (list ':allocation alloc)))
617 492
618 ;; The default type specifier is supposed to be t, meaning anything. 493 ;; The default type specifier is supposed to be t, meaning anything.
619 (if (not type) (setq type t)) 494 (if (not type) (setq type t))
620 495
621 ;; Label is nil, or a string
622 (if (not (or (null label) (stringp label)))
623 (signal 'invalid-slot-type (list ':label label)))
624
625 ;; Is there an initarg, but allocation of class?
626 (if (and initarg (eq alloc :class))
627 (message "Class allocated slots do not need :initarg"))
628
629 ;; intern the symbol so we can use it blankly 496 ;; intern the symbol so we can use it blankly
630 (if initarg (set initarg initarg)) 497 (if eieio-backward-compatibility
498 (and initarg (not (keywordp initarg))
499 (progn
500 (set initarg initarg)
501 (make-obsolete-variable
502 initarg (format "use '%s instead" initarg) "25.1"))))
631 503
632 ;; The customgroup should be a list of symbols 504 ;; The customgroup should be a list of symbols
633 (cond ((null customg) 505 (cond ((null customg)
@@ -637,131 +509,60 @@ See `defclass' for more information."
637 ;; The customgroup better be a symbol, or list of symbols. 509 ;; The customgroup better be a symbol, or list of symbols.
638 (mapc (lambda (cg) 510 (mapc (lambda (cg)
639 (if (not (symbolp cg)) 511 (if (not (symbolp cg))
640 (signal 'invalid-slot-type (list ':group cg)))) 512 (signal 'invalid-slot-type (list :group cg))))
641 customg) 513 customg)
642 514
643 ;; First up, add this slot into our new class. 515 ;; First up, add this slot into our new class.
644 (eieio-add-new-slot newc name init docstr type custom label customg printer 516 (eieio--add-new-slot newc name init docstr type custom label customg printer
645 prot initarg alloc 'defaultoverride skip-nil) 517 prot initarg alloc 'defaultoverride skip-nil)
646 518
647 ;; We need to id the group, and store them in a group list attribute. 519 ;; We need to id the group, and store them in a group list attribute.
648 (mapc (lambda (cg) (cl-pushnew cg groups :test 'equal)) customg) 520 (dolist (cg customg)
649 521 (cl-pushnew cg groups :test 'equal))
650 ;; Anyone can have an accessor function. This creates a function 522 ))
651 ;; of the specified name, and also performs a `defsetf' if applicable
652 ;; so that users can `setf' the space returned by this function.
653 (if acces
654 (progn
655 (eieio--defmethod
656 acces (if (eq alloc :class) :static :primary) cname
657 `(lambda (this)
658 ,(format
659 "Retrieves the slot `%s' from an object of class `%s'"
660 name cname)
661 (if (slot-boundp this ',name)
662 (eieio-oref this ',name)
663 ;; Else - Some error? nil?
664 nil)))
665
666 ;; FIXME: We should move more of eieio-defclass into the
667 ;; defclass macro so we don't have to use `eval' and require
668 ;; `gv' at run-time.
669 (eval `(gv-define-setter ,acces (eieio--store eieio--object)
670 (list 'eieio-oset eieio--object '',name
671 eieio--store)))))
672
673 ;; If a writer is defined, then create a generic method of that
674 ;; name whose purpose is to set the value of the slot.
675 (if writer
676 (eieio--defmethod
677 writer nil cname
678 `(lambda (this value)
679 ,(format "Set the slot `%s' of an object of class `%s'"
680 name cname)
681 (setf (slot-value this ',name) value))))
682 ;; If a reader is defined, then create a generic method
683 ;; of that name whose purpose is to access this slot value.
684 (if reader
685 (eieio--defmethod
686 reader nil cname
687 `(lambda (this)
688 ,(format "Access the slot `%s' from object of class `%s'"
689 name cname)
690 (slot-value this ',name))))
691 )
692 (setq slots (cdr slots)))
693 523
694 ;; Now that everything has been loaded up, all our lists are backwards! 524 ;; Now that everything has been loaded up, all our lists are backwards!
695 ;; Fix that up now. 525 ;; Fix that up now.
696 (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) 526 (cl-callf nreverse (eieio--class-public-a newc))
697 (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) 527 (cl-callf nreverse (eieio--class-public-d newc))
698 (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) 528 (cl-callf nreverse (eieio--class-public-doc newc))
699 (setf (eieio--class-public-type newc) 529 (cl-callf (lambda (types) (apply #'vector (nreverse types)))
700 (apply #'vector (nreverse (eieio--class-public-type newc)))) 530 (eieio--class-public-type newc))
701 (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) 531 (cl-callf nreverse (eieio--class-public-custom newc))
702 (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) 532 (cl-callf nreverse (eieio--class-public-custom-label newc))
703 (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) 533 (cl-callf nreverse (eieio--class-public-custom-group newc))
704 (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) 534 (cl-callf nreverse (eieio--class-public-printer newc))
705 (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) 535 (cl-callf nreverse (eieio--class-protection newc))
706 (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) 536 (cl-callf nreverse (eieio--class-initarg-tuples newc))
707 537
708 ;; The storage for class-class-allocation-type needs to be turned into 538 ;; The storage for class-class-allocation-type needs to be turned into
709 ;; a vector now. 539 ;; a vector now.
710 (setf (eieio--class-class-allocation-type newc) 540 (cl-callf (lambda (cat) (apply #'vector cat))
711 (apply #'vector (eieio--class-class-allocation-type newc))) 541 (eieio--class-class-allocation-type newc))
712 542
713 ;; Also, take class allocated values, and vectorize them for speed. 543 ;; Also, take class allocated values, and vectorize them for speed.
714 (setf (eieio--class-class-allocation-values newc) 544 (cl-callf (lambda (cavs) (apply #'vector cavs))
715 (apply #'vector (eieio--class-class-allocation-values newc))) 545 (eieio--class-class-allocation-values newc))
716 546
717 ;; Attach slot symbols into an obarray, and store the index of 547 ;; Attach slot symbols into a hashtable, and store the index of
718 ;; this slot as the variable slot in this new symbol. We need to 548 ;; this slot as the value this table.
719 ;; know about primes, because obarrays are best set in vectors of
720 ;; prime number length, and we also need to make our vector small
721 ;; to save space, and also optimal for the number of items we have.
722 (let* ((cnt 0) 549 (let* ((cnt 0)
723 (pubsyms (eieio--class-public-a newc)) 550 (pubsyms (eieio--class-public-a newc))
724 (prots (eieio--class-protection newc)) 551 (prots (eieio--class-protection newc))
725 (l (length pubsyms)) 552 (oa (make-hash-table :test #'eq)))
726 (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47
727 53 59 61 67 71 73 79 83 89 97 101 )))
728 (while (and primes (< (car primes) l))
729 (setq primes (cdr primes)))
730 (car primes)))
731 (oa (make-vector vl 0))
732 (newsym))
733 (while pubsyms 553 (while pubsyms
734 (setq newsym (intern (symbol-name (car pubsyms)) oa)) 554 (let ((newsym (list cnt)))
735 (set newsym cnt) 555 (setf (gethash (car pubsyms) oa) newsym)
736 (setq cnt (1+ cnt)) 556 (setq cnt (1+ cnt))
737 (if (car prots) (put newsym 'protection (car prots))) 557 (if (car prots) (setcdr newsym (car prots))))
738 (setq pubsyms (cdr pubsyms) 558 (setq pubsyms (cdr pubsyms)
739 prots (cdr prots))) 559 prots (cdr prots)))
740 (setf (eieio--class-symbol-obarray newc) oa) 560 (setf (eieio--class-symbol-hashtable newc) oa))
741 )
742
743 ;; Create the constructor function
744 (if (class-option-assoc options :abstract)
745 ;; Abstract classes cannot be instantiated. Say so.
746 (let ((abs (class-option-assoc options :abstract)))
747 (if (not (stringp abs))
748 (setq abs (format "Class %s is abstract" cname)))
749 (fset cname
750 `(lambda (&rest stuff)
751 ,(format "You cannot create a new object of type %s" cname)
752 (error ,abs))))
753
754 ;; Non-abstract classes need a constructor.
755 (fset cname
756 `(lambda (newname &rest slots)
757 ,(format "Create a new object with name NAME of class type %s" cname)
758 (apply #'constructor ,cname newname slots)))
759 )
760 561
761 ;; Set up a specialized doc string. 562 ;; Set up a specialized doc string.
762 ;; Use stored value since it is calculated in a non-trivial way 563 ;; Use stored value since it is calculated in a non-trivial way
763 (put cname 'variable-documentation 564 (put cname 'variable-documentation
764 (class-option-assoc options :documentation)) 565 (eieio--class-option-assoc options :documentation))
765 566
766 ;; Save the file location where this class is defined. 567 ;; Save the file location where this class is defined.
767 (let ((fname (if load-in-progress 568 (let ((fname (if load-in-progress
@@ -773,7 +574,7 @@ See `defclass' for more information."
773 (put cname 'class-location fname))) 574 (put cname 'class-location fname)))
774 575
775 ;; We have a list of custom groups. Store them into the options. 576 ;; We have a list of custom groups. Store them into the options.
776 (let ((g (class-option-assoc options :custom-groups))) 577 (let ((g (eieio--class-option-assoc options :custom-groups)))
777 (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) 578 (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups)
778 (if (memq :custom-groups options) 579 (if (memq :custom-groups options)
779 (setcar (cdr (memq :custom-groups options)) g) 580 (setcar (cdr (memq :custom-groups options)) g)
@@ -787,11 +588,17 @@ See `defclass' for more information."
787 (if clearparent (setf (eieio--class-parent newc) nil)) 588 (if clearparent (setf (eieio--class-parent newc) nil))
788 589
789 ;; Create the cached default object. 590 ;; Create the cached default object.
790 (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) 591 (let ((cache (make-vector (+ (length (eieio--class-public-a newc))
791 nil))) 592 (eval-when-compile eieio--object-num-slots))
792 (aset cache 0 'object) 593 nil))
793 (setf (eieio--object-class cache) cname) 594 ;; We don't strictly speaking need to use a symbol, but the old
794 (setf (eieio--object-name cache) 'default-cache-object) 595 ;; code used the class's name rather than the class's object, so
596 ;; we follow this preference for using a symbol, which is probably
597 ;; convenient to keep the printed representation of such Elisp
598 ;; objects readable.
599 (tag (intern (format "eieio-class-tag--%s" cname))))
600 (set tag newc)
601 (setf (eieio--object-class-tag cache) tag)
795 (let ((eieio-skip-typecheck t)) 602 (let ((eieio-skip-typecheck t))
796 ;; All type-checking has been done to our satisfaction 603 ;; All type-checking has been done to our satisfaction
797 ;; before this call. Don't waste our time in this call.. 604 ;; before this call. Don't waste our time in this call..
@@ -807,16 +614,16 @@ See `defclass' for more information."
807 "Whether the default value VAL should be evaluated for use." 614 "Whether the default value VAL should be evaluated for use."
808 (and (consp val) (symbolp (car val)) (fboundp (car val)))) 615 (and (consp val) (symbolp (car val)) (fboundp (car val))))
809 616
810(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) 617(defun eieio--perform-slot-validation-for-default (slot spec value skipnil)
811 "For SLOT, signal if SPEC does not match VALUE. 618 "For SLOT, signal if SPEC does not match VALUE.
812If SKIPNIL is non-nil, then if VALUE is nil return t instead." 619If SKIPNIL is non-nil, then if VALUE is nil return t instead."
813 (if (and (not (eieio-eval-default-p value)) 620 (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
814 (not eieio-skip-typecheck) 621 eieio-skip-typecheck
815 (not (and skipnil (null value))) 622 (and skipnil (null value))
816 (not (eieio-perform-slot-validation spec value))) 623 (eieio--perform-slot-validation spec value)))
817 (signal 'invalid-slot-type (list slot spec value)))) 624 (signal 'invalid-slot-type (list slot spec value))))
818 625
819(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc 626(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc
820 &optional defaultoverride skipnil) 627 &optional defaultoverride skipnil)
821 "Add into NEWC attribute A. 628 "Add into NEWC attribute A.
822If A already exists in NEWC, then do nothing. If it doesn't exist, 629If A already exists in NEWC, then do nothing. If it doesn't exist,
@@ -837,9 +644,9 @@ if default value is nil."
837 644
838 ;; To prevent override information w/out specification of storage, 645 ;; To prevent override information w/out specification of storage,
839 ;; we need to do this little hack. 646 ;; we need to do this little hack.
840 (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) 647 (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class))
841 648
842 (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) 649 (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance)))
843 ;; In this case, we modify the INSTANCE version of a given slot. 650 ;; In this case, we modify the INSTANCE version of a given slot.
844 651
845 (progn 652 (progn
@@ -847,16 +654,16 @@ if default value is nil."
847 ;; Only add this element if it is so-far unique 654 ;; Only add this element if it is so-far unique
848 (if (not (member a (eieio--class-public-a newc))) 655 (if (not (member a (eieio--class-public-a newc)))
849 (progn 656 (progn
850 (eieio-perform-slot-validation-for-default a type d skipnil) 657 (eieio--perform-slot-validation-for-default a type d skipnil)
851 (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) 658 (push a (eieio--class-public-a newc))
852 (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) 659 (push d (eieio--class-public-d newc))
853 (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) 660 (push doc (eieio--class-public-doc newc))
854 (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) 661 (push type (eieio--class-public-type newc))
855 (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) 662 (push cust (eieio--class-public-custom newc))
856 (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) 663 (push label (eieio--class-public-custom-label newc))
857 (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) 664 (push custg (eieio--class-public-custom-group newc))
858 (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) 665 (push print (eieio--class-public-printer newc))
859 (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) 666 (push prot (eieio--class-protection newc))
860 (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) 667 (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc)))
861 ) 668 )
862 ;; When defaultoverride is true, we are usually adding new local 669 ;; When defaultoverride is true, we are usually adding new local
@@ -882,7 +689,7 @@ if default value is nil."
882 type tp a))) 689 type tp a)))
883 ;; If we have a repeat, only update the initarg... 690 ;; If we have a repeat, only update the initarg...
884 (unless (eq d eieio-unbound) 691 (unless (eq d eieio-unbound)
885 (eieio-perform-slot-validation-for-default a tp d skipnil) 692 (eieio--perform-slot-validation-for-default a tp d skipnil)
886 (setcar dp d)) 693 (setcar dp d))
887 ;; If we have a new initarg, check for it. 694 ;; If we have a new initarg, check for it.
888 (when init 695 (when init
@@ -959,19 +766,19 @@ if default value is nil."
959 (let ((value (eieio-default-eval-maybe d))) 766 (let ((value (eieio-default-eval-maybe d)))
960 (if (not (member a (eieio--class-class-allocation-a newc))) 767 (if (not (member a (eieio--class-class-allocation-a newc)))
961 (progn 768 (progn
962 (eieio-perform-slot-validation-for-default a type value skipnil) 769 (eieio--perform-slot-validation-for-default a type value skipnil)
963 ;; Here we have found a :class version of a slot. This 770 ;; Here we have found a :class version of a slot. This
964 ;; requires a very different approach. 771 ;; requires a very different approach.
965 (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) 772 (push a (eieio--class-class-allocation-a newc))
966 (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) 773 (push doc (eieio--class-class-allocation-doc newc))
967 (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) 774 (push type (eieio--class-class-allocation-type newc))
968 (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) 775 (push cust (eieio--class-class-allocation-custom newc))
969 (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) 776 (push label (eieio--class-class-allocation-custom-label newc))
970 (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) 777 (push custg (eieio--class-class-allocation-custom-group newc))
971 (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) 778 (push prot (eieio--class-class-allocation-protection newc))
972 ;; Default value is stored in the 'values section, since new objects 779 ;; Default value is stored in the 'values section, since new objects
973 ;; can't initialize from this element. 780 ;; can't initialize from this element.
974 (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) 781 (push value (eieio--class-class-allocation-values newc)))
975 (when defaultoverride 782 (when defaultoverride
976 ;; There is a match, and we must override the old value. 783 ;; There is a match, and we must override the old value.
977 (let* ((ca (eieio--class-class-allocation-a newc)) 784 (let* ((ca (eieio--class-class-allocation-a newc))
@@ -996,7 +803,7 @@ if default value is nil."
996 ;; is to change the default, so allow unbound in. 803 ;; is to change the default, so allow unbound in.
997 804
998 ;; If we have a repeat, only update the value... 805 ;; If we have a repeat, only update the value...
999 (eieio-perform-slot-validation-for-default a tp value skipnil) 806 (eieio--perform-slot-validation-for-default a tp value skipnil)
1000 (setcar dp value)) 807 (setcar dp value))
1001 808
1002 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is 809 ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
@@ -1045,246 +852,81 @@ if default value is nil."
1045 "Copy into NEWC the slots of PARENTS. 852 "Copy into NEWC the slots of PARENTS.
1046Follow the rules of not overwriting early parents when applying to 853Follow the rules of not overwriting early parents when applying to
1047the new child class." 854the new child class."
1048 (let ((ps (eieio--class-parent newc)) 855 (let ((sn (eieio--class-option-assoc (eieio--class-options newc)
1049 (sn (class-option-assoc (eieio--class-options newc) 856 :allow-nil-initform)))
1050 ':allow-nil-initform))) 857 (dolist (pcv (eieio--class-parent newc))
1051 (while ps
1052 ;; First, duplicate all the slots of the parent. 858 ;; First, duplicate all the slots of the parent.
1053 (let ((pcv (class-v (car ps)))) 859 (let ((pa (eieio--class-public-a pcv))
1054 (let ((pa (eieio--class-public-a pcv)) 860 (pd (eieio--class-public-d pcv))
1055 (pd (eieio--class-public-d pcv)) 861 (pdoc (eieio--class-public-doc pcv))
1056 (pdoc (eieio--class-public-doc pcv)) 862 (ptype (eieio--class-public-type pcv))
1057 (ptype (eieio--class-public-type pcv)) 863 (pcust (eieio--class-public-custom pcv))
1058 (pcust (eieio--class-public-custom pcv)) 864 (plabel (eieio--class-public-custom-label pcv))
1059 (plabel (eieio--class-public-custom-label pcv)) 865 (pcustg (eieio--class-public-custom-group pcv))
1060 (pcustg (eieio--class-public-custom-group pcv)) 866 (printer (eieio--class-public-printer pcv))
1061 (printer (eieio--class-public-printer pcv)) 867 (pprot (eieio--class-protection pcv))
1062 (pprot (eieio--class-protection pcv)) 868 (pinit (eieio--class-initarg-tuples pcv))
1063 (pinit (eieio--class-initarg-tuples pcv)) 869 (i 0))
1064 (i 0)) 870 (while pa
1065 (while pa 871 (eieio--add-new-slot newc
1066 (eieio-add-new-slot newc 872 (car pa) (car pd) (car pdoc) (aref ptype i)
1067 (car pa) (car pd) (car pdoc) (aref ptype i) 873 (car pcust) (car plabel) (car pcustg)
1068 (car pcust) (car plabel) (car pcustg) 874 (car printer)
1069 (car printer) 875 (car pprot) (car-safe (car pinit)) nil nil sn)
1070 (car pprot) (car-safe (car pinit)) nil nil sn) 876 ;; Increment each value.
1071 ;; Increment each value. 877 (setq pa (cdr pa)
1072 (setq pa (cdr pa) 878 pd (cdr pd)
1073 pd (cdr pd) 879 pdoc (cdr pdoc)
1074 pdoc (cdr pdoc) 880 i (1+ i)
1075 i (1+ i) 881 pcust (cdr pcust)
1076 pcust (cdr pcust) 882 plabel (cdr plabel)
1077 plabel (cdr plabel) 883 pcustg (cdr pcustg)
1078 pcustg (cdr pcustg) 884 printer (cdr printer)
1079 printer (cdr printer) 885 pprot (cdr pprot)
1080 pprot (cdr pprot) 886 pinit (cdr pinit))
1081 pinit (cdr pinit)) 887 )) ;; while/let
1082 )) ;; while/let 888 ;; Now duplicate all the class alloc slots.
1083 ;; Now duplicate all the class alloc slots. 889 (let ((pa (eieio--class-class-allocation-a pcv))
1084 (let ((pa (eieio--class-class-allocation-a pcv)) 890 (pdoc (eieio--class-class-allocation-doc pcv))
1085 (pdoc (eieio--class-class-allocation-doc pcv)) 891 (ptype (eieio--class-class-allocation-type pcv))
1086 (ptype (eieio--class-class-allocation-type pcv)) 892 (pcust (eieio--class-class-allocation-custom pcv))
1087 (pcust (eieio--class-class-allocation-custom pcv)) 893 (plabel (eieio--class-class-allocation-custom-label pcv))
1088 (plabel (eieio--class-class-allocation-custom-label pcv)) 894 (pcustg (eieio--class-class-allocation-custom-group pcv))
1089 (pcustg (eieio--class-class-allocation-custom-group pcv)) 895 (printer (eieio--class-class-allocation-printer pcv))
1090 (printer (eieio--class-class-allocation-printer pcv)) 896 (pprot (eieio--class-class-allocation-protection pcv))
1091 (pprot (eieio--class-class-allocation-protection pcv)) 897 (pval (eieio--class-class-allocation-values pcv))
1092 (pval (eieio--class-class-allocation-values pcv)) 898 (i 0))
1093 (i 0)) 899 (while pa
1094 (while pa 900 (eieio--add-new-slot newc
1095 (eieio-add-new-slot newc 901 (car pa) (aref pval i) (car pdoc) (aref ptype i)
1096 (car pa) (aref pval i) (car pdoc) (aref ptype i) 902 (car pcust) (car plabel) (car pcustg)
1097 (car pcust) (car plabel) (car pcustg) 903 (car printer)
1098 (car printer) 904 (car pprot) nil :class sn)
1099 (car pprot) nil ':class sn) 905 ;; Increment each value.
1100 ;; Increment each value. 906 (setq pa (cdr pa)
1101 (setq pa (cdr pa) 907 pdoc (cdr pdoc)
1102 pdoc (cdr pdoc) 908 pcust (cdr pcust)
1103 pcust (cdr pcust) 909 plabel (cdr plabel)
1104 plabel (cdr plabel) 910 pcustg (cdr pcustg)
1105 pcustg (cdr pcustg) 911 printer (cdr printer)
1106 printer (cdr printer) 912 pprot (cdr pprot)
1107 pprot (cdr pprot) 913 i (1+ i))
1108 i (1+ i)) 914 )))))
1109 ))) ;; while/let
1110 ;; Loop over each parent class
1111 (setq ps (cdr ps)))
1112 ))
1113 915
1114 916
1115;;; CLOS methods and generics
1116;;
1117
1118(defun eieio--defgeneric-init-form (method doc-string)
1119 "Form to use for the initial definition of a generic."
1120 (cond
1121 ((or (not (fboundp method))
1122 (eq 'autoload (car-safe (symbol-function method))))
1123 ;; Make sure the method tables are installed.
1124 (eieiomt-install method)
1125 ;; Construct the actual body of this function.
1126 (eieio-defgeneric-form method doc-string))
1127 ((generic-p method) (symbol-function method)) ;Leave it as-is.
1128 (t (error "You cannot create a generic/method over an existing symbol: %s"
1129 method))))
1130
1131(defun eieio-defgeneric-form (method doc-string)
1132 "The lambda form that would be used as the function defined on METHOD.
1133All methods should call the same EIEIO function for dispatch.
1134DOC-STRING is the documentation attached to METHOD."
1135 `(lambda (&rest local-args)
1136 ,doc-string
1137 (eieio-generic-call (quote ,method) local-args)))
1138
1139(defsubst eieio-defgeneric-reset-generic-form (method)
1140 "Setup METHOD to call the generic form."
1141 (let ((doc-string (documentation method)))
1142 (fset method (eieio-defgeneric-form method doc-string))))
1143
1144(defun eieio-defgeneric-form-primary-only (method doc-string)
1145 "The lambda form that would be used as the function defined on METHOD.
1146All methods should call the same EIEIO function for dispatch.
1147DOC-STRING is the documentation attached to METHOD."
1148 `(lambda (&rest local-args)
1149 ,doc-string
1150 (eieio-generic-call-primary-only (quote ,method) local-args)))
1151
1152(defsubst eieio-defgeneric-reset-generic-form-primary-only (method)
1153 "Setup METHOD to call the generic form."
1154 (let ((doc-string (documentation method)))
1155 (fset method (eieio-defgeneric-form-primary-only method doc-string))))
1156
1157(declare-function no-applicable-method "eieio" (object method &rest args))
1158
1159(defun eieio-defgeneric-form-primary-only-one (method doc-string
1160 class
1161 impl
1162 )
1163 "The lambda form that would be used as the function defined on METHOD.
1164All methods should call the same EIEIO function for dispatch.
1165DOC-STRING is the documentation attached to METHOD.
1166CLASS is the class symbol needed for private method access.
1167IMPL is the symbol holding the method implementation."
1168 ;; NOTE: I tried out byte compiling this little fcn. Turns out it
1169 ;; is faster to execute this for not byte-compiled. ie, install this,
1170 ;; then measure calls going through here. I wonder why.
1171 (require 'bytecomp)
1172 (let ((byte-compile-warnings nil))
1173 (byte-compile
1174 `(lambda (&rest local-args)
1175 ,doc-string
1176 ;; This is a cool cheat. Usually we need to look up in the
1177 ;; method table to find out if there is a method or not. We can
1178 ;; instead make that determination at load time when there is
1179 ;; only one method. If the first arg is not a child of the class
1180 ;; of that one implementation, then clearly, there is no method def.
1181 (if (not (eieio-object-p (car local-args)))
1182 ;; Not an object. Just signal.
1183 (signal 'no-method-definition
1184 (list ',method local-args))
1185
1186 ;; We do have an object. Make sure it is the right type.
1187 (if ,(if (eq class eieio-default-superclass)
1188 nil ; default superclass means just an obj. Already asked.
1189 `(not (child-of-class-p (eieio--object-class (car local-args))
1190 ',class)))
1191
1192 ;; If not the right kind of object, call no applicable
1193 (apply #'no-applicable-method (car local-args)
1194 ',method local-args)
1195
1196 ;; It is ok, do the call.
1197 ;; Fill in inter-call variables then evaluate the method.
1198 (let ((eieio-generic-call-next-method-list nil)
1199 (eieio-generic-call-key method-primary)
1200 (eieio-generic-call-methodname ',method)
1201 (eieio-generic-call-arglst local-args)
1202 )
1203 (eieio--with-scoped-class ',class
1204 ,(if (< emacs-major-version 24)
1205 `(apply ,(list 'quote impl) local-args)
1206 `(apply #',impl local-args)))
1207 ;(,impl local-args)
1208 )))))))
1209
1210(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
1211 "Setup METHOD to call the generic form."
1212 (let* ((doc-string (documentation method))
1213 (M (get method 'eieio-method-tree))
1214 (entry (car (aref M method-primary)))
1215 )
1216 (fset method (eieio-defgeneric-form-primary-only-one
1217 method doc-string
1218 (car entry)
1219 (cdr entry)
1220 ))))
1221
1222(defun eieio-unbind-method-implementations (method)
1223 "Make the generic method METHOD have no implementations.
1224It will leave the original generic function in place,
1225but remove reference to all implementations of METHOD."
1226 (put method 'eieio-method-tree nil)
1227 (put method 'eieio-method-obarray nil))
1228
1229(defun eieio--defmethod (method kind argclass code)
1230 "Work part of the `defmethod' macro defining METHOD with ARGS."
1231 (let ((key
1232 ;; Find optional keys.
1233 (cond ((memq kind '(:BEFORE :before)) method-before)
1234 ((memq kind '(:AFTER :after)) method-after)
1235 ((memq kind '(:STATIC :static)) method-static)
1236 ((memq kind '(:PRIMARY :primary nil)) method-primary)
1237 ;; Primary key.
1238 ;; (t method-primary)
1239 (t (error "Unknown method kind %S" kind)))))
1240 ;; Make sure there is a generic (when called from defclass).
1241 (eieio--defalias
1242 method (eieio--defgeneric-init-form
1243 method (or (documentation code)
1244 (format "Generically created method `%s'." method))))
1245 ;; Create symbol for property to bind to. If the first arg is of
1246 ;; the form (varname vartype) and `vartype' is a class, then
1247 ;; that class will be the type symbol. If not, then it will fall
1248 ;; under the type `primary' which is a non-specific calling of the
1249 ;; function.
1250 (if argclass
1251 (if (not (class-p argclass))
1252 (error "Unknown class type %s in method parameters"
1253 argclass))
1254 ;; Generics are higher.
1255 (setq key (eieio-specialized-key-to-generic-key key)))
1256 ;; Put this lambda into the symbol so we can find it.
1257 (eieiomt-add method code key argclass)
1258 )
1259
1260 (when eieio-optimize-primary-methods-flag
1261 ;; Optimizing step:
1262 ;;
1263 ;; If this method, after this setup, only has primary methods, then
1264 ;; we can setup the generic that way.
1265 (if (generic-primary-only-p method)
1266 ;; If there is only one primary method, then we can go one more
1267 ;; optimization step.
1268 (if (generic-primary-only-one-p method)
1269 (eieio-defgeneric-reset-generic-form-primary-only-one method)
1270 (eieio-defgeneric-reset-generic-form-primary-only method))
1271 (eieio-defgeneric-reset-generic-form method)))
1272
1273 method)
1274
1275;;; Slot type validation 917;;; Slot type validation
1276 918
1277;; This is a hideous hack for replacing `typep' from cl-macs, to avoid 919;; This is a hideous hack for replacing `typep' from cl-macs, to avoid
1278;; requiring the CL library at run-time. It can be eliminated if/when 920;; requiring the CL library at run-time. It can be eliminated if/when
1279;; `typep' is merged into Emacs core. 921;; `typep' is merged into Emacs core.
1280 922
1281(defun eieio-perform-slot-validation (spec value) 923(defun eieio--perform-slot-validation (spec value)
1282 "Return non-nil if SPEC does not match VALUE." 924 "Return non-nil if SPEC does not match VALUE."
1283 (or (eq spec t) ; t always passes 925 (or (eq spec t) ; t always passes
1284 (eq value eieio-unbound) ; unbound always passes 926 (eq value eieio-unbound) ; unbound always passes
1285 (cl-typep value spec))) 927 (cl-typep value spec)))
1286 928
1287(defun eieio-validate-slot-value (class slot-idx value slot) 929(defun eieio--validate-slot-value (class slot-idx value slot)
1288 "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. 930 "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
1289Checks the :type specifier. 931Checks the :type specifier.
1290SLOT is the slot that is being checked, and is only used when throwing 932SLOT is the slot that is being checked, and is only used when throwing
@@ -1292,22 +934,24 @@ an error."
1292 (if eieio-skip-typecheck 934 (if eieio-skip-typecheck
1293 nil 935 nil
1294 ;; Trim off object IDX junk added in for the object index. 936 ;; Trim off object IDX junk added in for the object index.
1295 (setq slot-idx (- slot-idx 3)) 937 (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
1296 (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) 938 (let ((st (aref (eieio--class-public-type class) slot-idx)))
1297 (if (not (eieio-perform-slot-validation st value)) 939 (if (not (eieio--perform-slot-validation st value))
1298 (signal 'invalid-slot-type (list class slot st value)))))) 940 (signal 'invalid-slot-type
941 (list (eieio--class-symbol class) slot st value))))))
1299 942
1300(defun eieio-validate-class-slot-value (class slot-idx value slot) 943(defun eieio--validate-class-slot-value (class slot-idx value slot)
1301 "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. 944 "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
1302Checks the :type specifier. 945Checks the :type specifier.
1303SLOT is the slot that is being checked, and is only used when throwing 946SLOT is the slot that is being checked, and is only used when throwing
1304an error." 947an error."
1305 (if eieio-skip-typecheck 948 (if eieio-skip-typecheck
1306 nil 949 nil
1307 (let ((st (aref (eieio--class-class-allocation-type (class-v class)) 950 (let ((st (aref (eieio--class-class-allocation-type class)
1308 slot-idx))) 951 slot-idx)))
1309 (if (not (eieio-perform-slot-validation st value)) 952 (if (not (eieio--perform-slot-validation st value))
1310 (signal 'invalid-slot-type (list class slot st value)))))) 953 (signal 'invalid-slot-type
954 (list (eieio--class-symbol class) slot st value))))))
1311 955
1312(defun eieio-barf-if-slot-unbound (value instance slotname fn) 956(defun eieio-barf-if-slot-unbound (value instance slotname fn)
1313 "Throw a signal if VALUE is a representation of an UNBOUND slot. 957 "Throw a signal if VALUE is a representation of an UNBOUND slot.
@@ -1315,7 +959,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending
1315slot. If the slot is ok, return VALUE. 959slot. If the slot is ok, return VALUE.
1316Argument FN is the function calling this verifier." 960Argument FN is the function calling this verifier."
1317 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) 961 (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
1318 (slot-unbound instance (eieio--object-class instance) slotname fn) 962 (slot-unbound instance (eieio--object-class-name instance) slotname fn)
1319 value)) 963 value))
1320 964
1321 965
@@ -1326,14 +970,17 @@ Argument FN is the function calling this verifier."
1326 (eieio--check-type (or eieio-object-p class-p) obj) 970 (eieio--check-type (or eieio-object-p class-p) obj)
1327 (eieio--check-type symbolp slot) 971 (eieio--check-type symbolp slot)
1328 (if (class-p obj) (eieio-class-un-autoload obj)) 972 (if (class-p obj) (eieio-class-un-autoload obj))
1329 (let* ((class (if (class-p obj) obj (eieio--object-class obj))) 973 (let* ((class (cond ((symbolp obj)
1330 (c (eieio-slot-name-index class obj slot))) 974 (error "eieio-oref called on a class!")
975 (eieio--class-v obj))
976 (t (eieio--object-class-object obj))))
977 (c (eieio--slot-name-index class obj slot)))
1331 (if (not c) 978 (if (not c)
1332 ;; It might be missing because it is a :class allocated slot. 979 ;; It might be missing because it is a :class allocated slot.
1333 ;; Let's check that info out. 980 ;; Let's check that info out.
1334 (if (setq c (eieio-class-slot-name-index class slot)) 981 (if (setq c (eieio--class-slot-name-index class slot))
1335 ;; Oref that slot. 982 ;; Oref that slot.
1336 (aref (eieio--class-class-allocation-values (class-v class)) c) 983 (aref (eieio--class-class-allocation-values class) c)
1337 ;; The slot-missing method is a cool way of allowing an object author 984 ;; The slot-missing method is a cool way of allowing an object author
1338 ;; to intercept missing slot definitions. Since it is also the LAST 985 ;; to intercept missing slot definitions. Since it is also the LAST
1339 ;; thing called in this fn, its return value would be retrieved. 986 ;; thing called in this fn, its return value would be retrieved.
@@ -1349,26 +996,30 @@ Argument FN is the function calling this verifier."
1349Fills in OBJ's SLOT with its default value." 996Fills in OBJ's SLOT with its default value."
1350 (eieio--check-type (or eieio-object-p class-p) obj) 997 (eieio--check-type (or eieio-object-p class-p) obj)
1351 (eieio--check-type symbolp slot) 998 (eieio--check-type symbolp slot)
1352 (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) 999 (let* ((cl (cond ((symbolp obj) (eieio--class-v obj))
1353 (c (eieio-slot-name-index cl obj slot))) 1000 (t (eieio--object-class-object obj))))
1001 (c (eieio--slot-name-index cl obj slot)))
1354 (if (not c) 1002 (if (not c)
1355 ;; It might be missing because it is a :class allocated slot. 1003 ;; It might be missing because it is a :class allocated slot.
1356 ;; Let's check that info out. 1004 ;; Let's check that info out.
1357 (if (setq c 1005 (if (setq c
1358 (eieio-class-slot-name-index cl slot)) 1006 (eieio--class-slot-name-index cl slot))
1359 ;; Oref that slot. 1007 ;; Oref that slot.
1360 (aref (eieio--class-class-allocation-values (class-v cl)) 1008 (aref (eieio--class-class-allocation-values cl)
1361 c) 1009 c)
1362 (slot-missing obj slot 'oref-default) 1010 (slot-missing obj slot 'oref-default)
1363 ;;(signal 'invalid-slot-name (list (class-name cl) slot)) 1011 ;;(signal 'invalid-slot-name (list (class-name cl) slot))
1364 ) 1012 )
1365 (eieio-barf-if-slot-unbound 1013 (eieio-barf-if-slot-unbound
1366 (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) 1014 (let ((val (nth (- c (eval-when-compile eieio--object-num-slots))
1015 (eieio--class-public-d cl))))
1367 (eieio-default-eval-maybe val)) 1016 (eieio-default-eval-maybe val))
1368 obj cl 'oref-default)))) 1017 obj (eieio--class-symbol cl) 'oref-default))))
1369 1018
1370(defun eieio-default-eval-maybe (val) 1019(defun eieio-default-eval-maybe (val)
1371 "Check VAL, and return what `oref-default' would provide." 1020 "Check VAL, and return what `oref-default' would provide."
1021 ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate
1022 ;; variables as well? Why not just always call `eval'?
1372 (cond 1023 (cond
1373 ;; Is it a function call? If so, evaluate it. 1024 ;; Is it a function call? If so, evaluate it.
1374 ((eieio-eval-default-p val) 1025 ((eieio-eval-default-p val)
@@ -1384,69 +1035,71 @@ Fills in OBJ's SLOT with its default value."
1384Fills in OBJ's SLOT with VALUE." 1035Fills in OBJ's SLOT with VALUE."
1385 (eieio--check-type eieio-object-p obj) 1036 (eieio--check-type eieio-object-p obj)
1386 (eieio--check-type symbolp slot) 1037 (eieio--check-type symbolp slot)
1387 (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) 1038 (let* ((class (eieio--object-class-object obj))
1039 (c (eieio--slot-name-index class obj slot)))
1388 (if (not c) 1040 (if (not c)
1389 ;; It might be missing because it is a :class allocated slot. 1041 ;; It might be missing because it is a :class allocated slot.
1390 ;; Let's check that info out. 1042 ;; Let's check that info out.
1391 (if (setq c 1043 (if (setq c
1392 (eieio-class-slot-name-index (eieio--object-class obj) slot)) 1044 (eieio--class-slot-name-index class slot))
1393 ;; Oset that slot. 1045 ;; Oset that slot.
1394 (progn 1046 (progn
1395 (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) 1047 (eieio--validate-class-slot-value class c value slot)
1396 (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) 1048 (aset (eieio--class-class-allocation-values class)
1397 c value)) 1049 c value))
1398 ;; See oref for comment on `slot-missing' 1050 ;; See oref for comment on `slot-missing'
1399 (slot-missing obj slot 'oset value) 1051 (slot-missing obj slot 'oset value)
1400 ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) 1052 ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot))
1401 ) 1053 )
1402 (eieio-validate-slot-value (eieio--object-class obj) c value slot) 1054 (eieio--validate-slot-value class c value slot)
1403 (aset obj c value)))) 1055 (aset obj c value))))
1404 1056
1405(defun eieio-oset-default (class slot value) 1057(defun eieio-oset-default (class slot value)
1406 "Do the work for the macro `oset-default'. 1058 "Do the work for the macro `oset-default'.
1407Fills in the default value in CLASS' in SLOT with VALUE." 1059Fills in the default value in CLASS' in SLOT with VALUE."
1408 (eieio--check-type class-p class) 1060 (setq class (eieio--class-object class))
1061 (eieio--check-type eieio--class-p class)
1409 (eieio--check-type symbolp slot) 1062 (eieio--check-type symbolp slot)
1410 (eieio--with-scoped-class class 1063 (eieio--with-scoped-class class
1411 (let* ((c (eieio-slot-name-index class nil slot))) 1064 (let* ((c (eieio--slot-name-index class nil slot)))
1412 (if (not c) 1065 (if (not c)
1413 ;; It might be missing because it is a :class allocated slot. 1066 ;; It might be missing because it is a :class allocated slot.
1414 ;; Let's check that info out. 1067 ;; Let's check that info out.
1415 (if (setq c (eieio-class-slot-name-index class slot)) 1068 (if (setq c (eieio--class-slot-name-index class slot))
1416 (progn 1069 (progn
1417 ;; Oref that slot. 1070 ;; Oref that slot.
1418 (eieio-validate-class-slot-value class c value slot) 1071 (eieio--validate-class-slot-value class c value slot)
1419 (aset (eieio--class-class-allocation-values (class-v class)) c 1072 (aset (eieio--class-class-allocation-values class) c
1420 value)) 1073 value))
1421 (signal 'invalid-slot-name (list (eieio-class-name class) slot))) 1074 (signal 'invalid-slot-name (list (eieio--class-symbol class) slot)))
1422 (eieio-validate-slot-value class c value slot) 1075 (eieio--validate-slot-value class c value slot)
1423 ;; Set this into the storage for defaults. 1076 ;; Set this into the storage for defaults.
1424 (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) 1077 (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
1078 (eieio--class-public-d class))
1425 value) 1079 value)
1426 ;; Take the value, and put it into our cache object. 1080 ;; Take the value, and put it into our cache object.
1427 (eieio-oset (eieio--class-default-object-cache (class-v class)) 1081 (eieio-oset (eieio--class-default-object-cache class)
1428 slot value) 1082 slot value)
1429 )))) 1083 ))))
1430 1084
1431 1085
1432;;; EIEIO internal search functions 1086;;; EIEIO internal search functions
1433;; 1087;;
1434(defun eieio-slot-originating-class-p (start-class slot) 1088(defun eieio--slot-originating-class-p (start-class slot)
1435 "Return non-nil if START-CLASS is the first class to define SLOT. 1089 "Return non-nil if START-CLASS is the first class to define SLOT.
1436This is for testing if the class currently in scope is the class that defines SLOT 1090This is for testing if the class currently in scope is the class that defines SLOT
1437so that we can protect private slots." 1091so that we can protect private slots."
1438 (let ((par (eieio-class-parents-fast start-class)) 1092 (let ((par (eieio--class-parent start-class))
1439 (ret t)) 1093 (ret t))
1440 (if (not par) 1094 (or (not par)
1441 t 1095 (progn
1442 (while (and par ret) 1096 (while (and par ret)
1443 (if (intern-soft (symbol-name slot) 1097 (if (gethash slot (eieio--class-symbol-hashtable (car par)))
1444 (eieio--class-symbol-obarray (class-v (car par)))) 1098 (setq ret nil))
1445 (setq ret nil)) 1099 (setq par (cdr par)))
1446 (setq par (cdr par))) 1100 ret))))
1447 ret))) 1101
1448 1102(defun eieio--slot-name-index (class obj slot)
1449(defun eieio-slot-name-index (class obj slot)
1450 "In CLASS for OBJ find the index of the named SLOT. 1103 "In CLASS for OBJ find the index of the named SLOT.
1451The slot is a symbol which is installed in CLASS by the `defclass' 1104The slot is a symbol which is installed in CLASS by the `defclass'
1452call. OBJ can be nil, but if it is an object, and the slot in question 1105call. OBJ can be nil, but if it is an object, and the slot in question
@@ -1455,36 +1108,41 @@ scoped class.
1455If SLOT is the value created with :initarg instead, 1108If SLOT is the value created with :initarg instead,
1456reverse-lookup that name, and recurse with the associated slot value." 1109reverse-lookup that name, and recurse with the associated slot value."
1457 ;; Removed checks to outside this call 1110 ;; Removed checks to outside this call
1458 (let* ((fsym (intern-soft (symbol-name slot) 1111 (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class)))
1459 (eieio--class-symbol-obarray (class-v class)))) 1112 (fsi (car fsym)))
1460 (fsi (if (symbolp fsym) (symbol-value fsym) nil)))
1461 (if (integerp fsi) 1113 (if (integerp fsi)
1462 (cond 1114 (cond
1463 ((not (get fsym 'protection)) 1115 ((not (cdr fsym))
1464 (+ 3 fsi)) 1116 (+ (eval-when-compile eieio--object-num-slots) fsi))
1465 ((and (eq (get fsym 'protection) 'protected) 1117 ((and (eq (cdr fsym) 'protected)
1466 (eieio--scoped-class) 1118 (eieio--scoped-class)
1467 (or (child-of-class-p class (eieio--scoped-class)) 1119 (or (child-of-class-p class (eieio--scoped-class))
1468 (and (eieio-object-p obj) 1120 (and (eieio-object-p obj)
1469 (child-of-class-p class (eieio--object-class obj))))) 1121 ;; AFAICT, for all callers, if `obj' is not a class,
1470 (+ 3 fsi)) 1122 ;; then its class is `class'.
1471 ((and (eq (get fsym 'protection) 'private) 1123 ;;(child-of-class-p class (eieio--object-class-object obj))
1124 (progn
1125 (cl-assert (eq class (eieio--object-class-object obj)))
1126 t))))
1127 (+ (eval-when-compile eieio--object-num-slots) fsi))
1128 ((and (eq (cdr fsym) 'private)
1472 (or (and (eieio--scoped-class) 1129 (or (and (eieio--scoped-class)
1473 (eieio-slot-originating-class-p (eieio--scoped-class) slot)) 1130 (eieio--slot-originating-class-p
1131 (eieio--scoped-class) slot))
1474 eieio-initializing-object)) 1132 eieio-initializing-object))
1475 (+ 3 fsi)) 1133 (+ (eval-when-compile eieio--object-num-slots) fsi))
1476 (t nil)) 1134 (t nil))
1477 (let ((fn (eieio-initarg-to-attribute class slot))) 1135 (let ((fn (eieio--initarg-to-attribute class slot)))
1478 (if fn (eieio-slot-name-index class obj fn) nil))))) 1136 (if fn (eieio--slot-name-index class obj fn) nil)))))
1479 1137
1480(defun eieio-class-slot-name-index (class slot) 1138(defun eieio--class-slot-name-index (class slot)
1481 "In CLASS find the index of the named SLOT. 1139 "In CLASS find the index of the named SLOT.
1482The slot is a symbol which is installed in CLASS by the `defclass' 1140The slot is a symbol which is installed in CLASS by the `defclass'
1483call. If SLOT is the value created with :initarg instead, 1141call. If SLOT is the value created with :initarg instead,
1484reverse-lookup that name, and recurse with the associated slot value." 1142reverse-lookup that name, and recurse with the associated slot value."
1485 ;; This will happen less often, and with fewer slots. Do this the 1143 ;; This will happen less often, and with fewer slots. Do this the
1486 ;; storage cheap way. 1144 ;; storage cheap way.
1487 (let* ((a (eieio--class-class-allocation-a (class-v class))) 1145 (let* ((a (eieio--class-class-allocation-a class))
1488 (l1 (length a)) 1146 (l1 (length a))
1489 (af (memq slot a)) 1147 (af (memq slot a))
1490 (l2 (length af))) 1148 (l2 (length af)))
@@ -1501,36 +1159,28 @@ reverse-lookup that name, and recurse with the associated slot value."
1501If SET-ALL is non-nil, then when a default is nil, that value is 1159If SET-ALL is non-nil, then when a default is nil, that value is
1502reset. If SET-ALL is nil, the slots are only reset if the default is 1160reset. If SET-ALL is nil, the slots are only reset if the default is
1503not nil." 1161not nil."
1504 (eieio--with-scoped-class (eieio--object-class obj) 1162 (eieio--with-scoped-class (eieio--object-class-object obj)
1505 (let ((eieio-initializing-object t) 1163 (let ((eieio-initializing-object t)
1506 (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) 1164 (pub (eieio--class-public-a (eieio--object-class-object obj))))
1507 (while pub 1165 (while pub
1508 (let ((df (eieio-oref-default obj (car pub)))) 1166 (let ((df (eieio-oref-default obj (car pub))))
1509 (if (or df set-all) 1167 (if (or df set-all)
1510 (eieio-oset obj (car pub) df))) 1168 (eieio-oset obj (car pub) df)))
1511 (setq pub (cdr pub)))))) 1169 (setq pub (cdr pub))))))
1512 1170
1513(defun eieio-initarg-to-attribute (class initarg) 1171(defun eieio--initarg-to-attribute (class initarg)
1514 "For CLASS, convert INITARG to the actual attribute name. 1172 "For CLASS, convert INITARG to the actual attribute name.
1515If there is no translation, pass it in directly (so we can cheat if 1173If there is no translation, pass it in directly (so we can cheat if
1516need be... May remove that later...)" 1174need be... May remove that later...)"
1517 (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) 1175 (let ((tuple (assoc initarg (eieio--class-initarg-tuples class))))
1518 (if tuple 1176 (if tuple
1519 (cdr tuple) 1177 (cdr tuple)
1520 nil))) 1178 nil)))
1521 1179
1522(defun eieio-attribute-to-initarg (class attribute)
1523 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
1524This is usually a symbol that starts with `:'."
1525 (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class)))))
1526 (if tuple
1527 (car tuple)
1528 nil)))
1529
1530;;; 1180;;;
1531;; Method Invocation order: C3 1181;; Method Invocation order: C3
1532(defun eieio-c3-candidate (class remaining-inputs) 1182(defun eieio--c3-candidate (class remaining-inputs)
1533 "Return CLASS if it can go in the result now, otherwise nil" 1183 "Return CLASS if it can go in the result now, otherwise nil."
1534 ;; Ensure CLASS is not in any position but the first in any of the 1184 ;; Ensure CLASS is not in any position but the first in any of the
1535 ;; element lists of REMAINING-INPUTS. 1185 ;; element lists of REMAINING-INPUTS.
1536 (and (not (let ((found nil)) 1186 (and (not (let ((found nil))
@@ -1540,7 +1190,7 @@ This is usually a symbol that starts with `:'."
1540 found)) 1190 found))
1541 class)) 1191 class))
1542 1192
1543(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) 1193(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
1544 "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. 1194 "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
1545If a consistent order does not exist, signal an error." 1195If a consistent order does not exist, signal an error."
1546 (if (let ((tail remaining-inputs) 1196 (if (let ((tail remaining-inputs)
@@ -1559,41 +1209,38 @@ If a consistent order does not exist, signal an error."
1559 (next (progn 1209 (next (progn
1560 (while (and tail (not found)) 1210 (while (and tail (not found))
1561 (setq found (and (car tail) 1211 (setq found (and (car tail)
1562 (eieio-c3-candidate (caar tail) 1212 (eieio--c3-candidate (caar tail)
1563 remaining-inputs)) 1213 remaining-inputs))
1564 tail (cdr tail))) 1214 tail (cdr tail)))
1565 found))) 1215 found)))
1566 (if next 1216 (if next
1567 ;; The graph is consistent so far, add NEXT to result and 1217 ;; The graph is consistent so far, add NEXT to result and
1568 ;; merge input lists, dropping NEXT from their heads where 1218 ;; merge input lists, dropping NEXT from their heads where
1569 ;; applicable. 1219 ;; applicable.
1570 (eieio-c3-merge-lists 1220 (eieio--c3-merge-lists
1571 (cons next reversed-partial-result) 1221 (cons next reversed-partial-result)
1572 (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) 1222 (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
1573 remaining-inputs)) 1223 remaining-inputs))
1574 ;; The graph is inconsistent, give up 1224 ;; The graph is inconsistent, give up
1575 (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) 1225 (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
1576 1226
1577(defun eieio-class-precedence-c3 (class) 1227(defun eieio--class-precedence-c3 (class)
1578 "Return all parents of CLASS in c3 order." 1228 "Return all parents of CLASS in c3 order."
1579 (let ((parents (eieio-class-parents-fast class))) 1229 (let ((parents (eieio--class-parent (eieio--class-v class))))
1580 (eieio-c3-merge-lists 1230 (eieio--c3-merge-lists
1581 (list class) 1231 (list class)
1582 (append 1232 (append
1583 (or 1233 (or
1584 (mapcar 1234 (mapcar #'eieio--class-precedence-c3 parents)
1585 (lambda (x) 1235 `((,eieio-default-superclass)))
1586 (eieio-class-precedence-c3 x))
1587 parents)
1588 '((eieio-default-superclass)))
1589 (list parents)))) 1236 (list parents))))
1590 ) 1237 )
1591;;; 1238;;;
1592;; Method Invocation Order: Depth First 1239;; Method Invocation Order: Depth First
1593 1240
1594(defun eieio-class-precedence-dfs (class) 1241(defun eieio--class-precedence-dfs (class)
1595 "Return all parents of CLASS in depth-first order." 1242 "Return all parents of CLASS in depth-first order."
1596 (let* ((parents (eieio-class-parents-fast class)) 1243 (let* ((parents (eieio--class-parent class))
1597 (classes (copy-sequence 1244 (classes (copy-sequence
1598 (apply #'append 1245 (apply #'append
1599 (list class) 1246 (list class)
@@ -1601,9 +1248,9 @@ If a consistent order does not exist, signal an error."
1601 (mapcar 1248 (mapcar
1602 (lambda (parent) 1249 (lambda (parent)
1603 (cons parent 1250 (cons parent
1604 (eieio-class-precedence-dfs parent))) 1251 (eieio--class-precedence-dfs parent)))
1605 parents) 1252 parents)
1606 '((eieio-default-superclass)))))) 1253 `((,eieio-default-superclass))))))
1607 (tail classes)) 1254 (tail classes))
1608 ;; Remove duplicates. 1255 ;; Remove duplicates.
1609 (while tail 1256 (while tail
@@ -1613,563 +1260,55 @@ If a consistent order does not exist, signal an error."
1613 1260
1614;;; 1261;;;
1615;; Method Invocation Order: Breadth First 1262;; Method Invocation Order: Breadth First
1616(defun eieio-class-precedence-bfs (class) 1263(defun eieio--class-precedence-bfs (class)
1617 "Return all parents of CLASS in breadth-first order." 1264 "Return all parents of CLASS in breadth-first order."
1618 (let ((result) 1265 (let* ((result)
1619 (queue (or (eieio-class-parents-fast class) 1266 (queue (or (eieio--class-parent class)
1620 '(eieio-default-superclass)))) 1267 `(,eieio-default-superclass))))
1621 (while queue 1268 (while queue
1622 (let ((head (pop queue))) 1269 (let ((head (pop queue)))
1623 (unless (member head result) 1270 (unless (member head result)
1624 (push head result) 1271 (push head result)
1625 (unless (eq head 'eieio-default-superclass) 1272 (unless (eq head eieio-default-superclass)
1626 (setq queue (append queue (or (eieio-class-parents-fast head) 1273 (setq queue (append queue (or (eieio--class-parent head)
1627 '(eieio-default-superclass)))))))) 1274 `(,eieio-default-superclass))))))))
1628 (cons class (nreverse result))) 1275 (cons class (nreverse result)))
1629 ) 1276 )
1630 1277
1631;;; 1278;;;
1632;; Method Invocation Order 1279;; Method Invocation Order
1633 1280
1634(defun eieio-class-precedence-list (class) 1281(defun eieio--class-precedence-list (class)
1635 "Return (transitively closed) list of parents of CLASS. 1282 "Return (transitively closed) list of parents of CLASS.
1636The order, in which the parents are returned depends on the 1283The order, in which the parents are returned depends on the
1637method invocation orders of the involved classes." 1284method invocation orders of the involved classes."
1638 (if (or (null class) (eq class 'eieio-default-superclass)) 1285 (if (or (null class) (eq class eieio-default-superclass))
1639 nil 1286 nil
1640 (cl-case (class-method-invocation-order class) 1287 (cl-case (eieio--class-method-invocation-order class)
1641 (:depth-first 1288 (:depth-first
1642 (eieio-class-precedence-dfs class)) 1289 (eieio--class-precedence-dfs class))
1643 (:breadth-first 1290 (:breadth-first
1644 (eieio-class-precedence-bfs class)) 1291 (eieio--class-precedence-bfs class))
1645 (:c3 1292 (:c3
1646 (eieio-class-precedence-c3 class)))) 1293 (eieio--class-precedence-c3 class))))
1647 ) 1294 )
1648(define-obsolete-function-alias 1295(define-obsolete-function-alias
1649 'class-precedence-list 'eieio-class-precedence-list "24.4") 1296 'class-precedence-list 'eieio--class-precedence-list "24.4")
1650
1651
1652;;; CLOS generics internal function handling
1653;;
1654(defvar eieio-generic-call-methodname nil
1655 "When using `call-next-method', provides a context on how to do it.")
1656(defvar eieio-generic-call-arglst nil
1657 "When using `call-next-method', provides a context for parameters.")
1658(defvar eieio-generic-call-key nil
1659 "When using `call-next-method', provides a context for the current key.
1660Keys are a number representing :before, :primary, and :after methods.")
1661(defvar eieio-generic-call-next-method-list nil
1662 "When executing a PRIMARY or STATIC method, track the 'next-method'.
1663During executions, the list is first generated, then as each next method
1664is called, the next method is popped off the stack.")
1665
1666(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks
1667 'eieio-pre-method-execution-functions "24.3")
1668(defvar eieio-pre-method-execution-functions nil
1669 "Abnormal hook run just before an EIEIO method is executed.
1670The hook function must accept one argument, the list of forms
1671about to be executed.")
1672
1673(defun eieio-generic-call (method args)
1674 "Call METHOD with ARGS.
1675ARGS provides the context on which implementation to use.
1676This should only be called from a generic function."
1677 ;; We must expand our arguments first as they are always
1678 ;; passed in as quoted symbols
1679 (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil)
1680 (eieio-generic-call-methodname method)
1681 (eieio-generic-call-arglst args)
1682 (firstarg nil)
1683 (primarymethodlist nil))
1684 ;; get a copy
1685 (setq newargs args
1686 firstarg (car newargs))
1687 ;; Is the class passed in autoloaded?
1688 ;; Since class names are also constructors, they can be autoloaded
1689 ;; via the autoload command. Check for this, and load them in.
1690 ;; It is ok if it doesn't turn out to be a class. Probably want that
1691 ;; function loaded anyway.
1692 (if (and (symbolp firstarg)
1693 (fboundp firstarg)
1694 (listp (symbol-function firstarg))
1695 (eq 'autoload (car (symbol-function firstarg))))
1696 (load (nth 1 (symbol-function firstarg))))
1697 ;; Determine the class to use.
1698 (cond ((eieio-object-p firstarg)
1699 (setq mclass (eieio--object-class firstarg)))
1700 ((class-p firstarg)
1701 (setq mclass firstarg))
1702 )
1703 ;; Make sure the class is a valid class
1704 ;; mclass can be nil (meaning a generic for should be used.
1705 ;; mclass cannot have a value that is not a class, however.
1706 (when (and (not (null mclass)) (not (class-p mclass)))
1707 (error "Cannot dispatch method %S on class %S"
1708 method mclass)
1709 )
1710 ;; Now create a list in reverse order of all the calls we have
1711 ;; make in order to successfully do this right. Rules:
1712 ;; 1) Only call generics if scoped-class is not defined
1713 ;; This prevents multiple calls in the case of recursion
1714 ;; 2) Only call static if this is a static method.
1715 ;; 3) Only call specifics if the definition allows for them.
1716 ;; 4) Call in order based on :before, :primary, and :after
1717 (when (eieio-object-p firstarg)
1718 ;; Non-static calls do all this stuff.
1719
1720 ;; :after methods
1721 (setq tlambdas
1722 (if mclass
1723 (eieiomt-method-list method method-after mclass)
1724 (list (eieio-generic-form method method-after nil)))
1725 ;;(or (and mclass (eieio-generic-form method method-after mclass))
1726 ;; (eieio-generic-form method method-after nil))
1727 )
1728 (setq lambdas (append tlambdas lambdas)
1729 keys (append (make-list (length tlambdas) method-after) keys))
1730
1731 ;; :primary methods
1732 (setq tlambdas
1733 (or (and mclass (eieio-generic-form method method-primary mclass))
1734 (eieio-generic-form method method-primary nil)))
1735 (when tlambdas
1736 (setq lambdas (cons tlambdas lambdas)
1737 keys (cons method-primary keys)
1738 primarymethodlist
1739 (eieiomt-method-list method method-primary mclass)))
1740
1741 ;; :before methods
1742 (setq tlambdas
1743 (if mclass
1744 (eieiomt-method-list method method-before mclass)
1745 (list (eieio-generic-form method method-before nil)))
1746 ;;(or (and mclass (eieio-generic-form method method-before mclass))
1747 ;; (eieio-generic-form method method-before nil))
1748 )
1749 (setq lambdas (append tlambdas lambdas)
1750 keys (append (make-list (length tlambdas) method-before) keys))
1751 )
1752
1753 (if mclass
1754 ;; For the case of a class,
1755 ;; if there were no methods found, then there could be :static methods.
1756 (when (not lambdas)
1757 (setq tlambdas
1758 (eieio-generic-form method method-static mclass))
1759 (setq lambdas (cons tlambdas lambdas)
1760 keys (cons method-static keys)
1761 primarymethodlist ;; Re-use even with bad name here
1762 (eieiomt-method-list method method-static mclass)))
1763 ;; For the case of no class (ie - mclass == nil) then there may
1764 ;; be a primary method.
1765 (setq tlambdas
1766 (eieio-generic-form method method-primary nil))
1767 (when tlambdas
1768 (setq lambdas (cons tlambdas lambdas)
1769 keys (cons method-primary keys)
1770 primarymethodlist
1771 (eieiomt-method-list method method-primary nil)))
1772 )
1773
1774 (run-hook-with-args 'eieio-pre-method-execution-functions
1775 primarymethodlist)
1776
1777 ;; Now loop through all occurrences forms which we must execute
1778 ;; (which are happily sorted now) and execute them all!
1779 (let ((rval nil) (lastval nil) (found nil))
1780 (while lambdas
1781 (if (car lambdas)
1782 (eieio--with-scoped-class (cdr (car lambdas))
1783 (let* ((eieio-generic-call-key (car keys))
1784 (has-return-val
1785 (or (= eieio-generic-call-key method-primary)
1786 (= eieio-generic-call-key method-static)))
1787 (eieio-generic-call-next-method-list
1788 ;; Use the cdr, as the first element is the fcn
1789 ;; we are calling right now.
1790 (when has-return-val (cdr primarymethodlist)))
1791 )
1792 (setq found t)
1793 ;;(setq rval (apply (car (car lambdas)) newargs))
1794 (setq lastval (apply (car (car lambdas)) newargs))
1795 (when has-return-val
1796 (setq rval lastval))
1797 )))
1798 (setq lambdas (cdr lambdas)
1799 keys (cdr keys)))
1800 (if (not found)
1801 (if (eieio-object-p (car args))
1802 (setq rval (apply #'no-applicable-method (car args) method args))
1803 (signal
1804 'no-method-definition
1805 (list method args))))
1806 rval)))
1807
1808(defun eieio-generic-call-primary-only (method args)
1809 "Call METHOD with ARGS for methods with only :PRIMARY implementations.
1810ARGS provides the context on which implementation to use.
1811This should only be called from a generic function.
1812
1813This method is like `eieio-generic-call', but only
1814implementations in the :PRIMARY slot are queried. After many
1815years of use, it appears that over 90% of methods in use
1816have :PRIMARY implementations only. We can therefore optimize
1817for this common case to improve performance."
1818 ;; We must expand our arguments first as they are always
1819 ;; passed in as quoted symbols
1820 (let ((newargs nil) (mclass nil) (lambdas nil)
1821 (eieio-generic-call-methodname method)
1822 (eieio-generic-call-arglst args)
1823 (firstarg nil)
1824 (primarymethodlist nil)
1825 )
1826 ;; get a copy
1827 (setq newargs args
1828 firstarg (car newargs))
1829
1830 ;; Determine the class to use.
1831 (cond ((eieio-object-p firstarg)
1832 (setq mclass (eieio--object-class firstarg)))
1833 ((not firstarg)
1834 (error "Method %s called on nil" method))
1835 ((not (eieio-object-p firstarg))
1836 (error "Primary-only method %s called on something not an object" method))
1837 (t
1838 (error "EIEIO Error: Improperly classified method %s as primary only"
1839 method)
1840 ))
1841 ;; Make sure the class is a valid class
1842 ;; mclass can be nil (meaning a generic for should be used.
1843 ;; mclass cannot have a value that is not a class, however.
1844 (when (null mclass)
1845 (error "Cannot dispatch method %S on class %S" method mclass)
1846 )
1847
1848 ;; :primary methods
1849 (setq lambdas (eieio-generic-form method method-primary mclass))
1850 (setq primarymethodlist ;; Re-use even with bad name here
1851 (eieiomt-method-list method method-primary mclass))
1852
1853 ;; Now loop through all occurrences forms which we must execute
1854 ;; (which are happily sorted now) and execute them all!
1855 (eieio--with-scoped-class (cdr lambdas)
1856 (let* ((rval nil) (lastval nil)
1857 (eieio-generic-call-key method-primary)
1858 ;; Use the cdr, as the first element is the fcn
1859 ;; we are calling right now.
1860 (eieio-generic-call-next-method-list (cdr primarymethodlist))
1861 )
1862
1863 (if (or (not lambdas) (not (car lambdas)))
1864
1865 ;; No methods found for this impl...
1866 (if (eieio-object-p (car args))
1867 (setq rval (apply #'no-applicable-method
1868 (car args) method args))
1869 (signal
1870 'no-method-definition
1871 (list method args)))
1872
1873 ;; Do the regular implementation here.
1874
1875 (run-hook-with-args 'eieio-pre-method-execution-functions
1876 lambdas)
1877
1878 (setq lastval (apply (car lambdas) newargs))
1879 (setq rval lastval))
1880
1881 rval))))
1882
1883(defun eieiomt-method-list (method key class)
1884 "Return an alist list of methods lambdas.
1885METHOD is the method name.
1886KEY represents either :before, or :after methods.
1887CLASS is the starting class to search from in the method tree.
1888If CLASS is nil, then an empty list of methods should be returned."
1889 ;; Note: eieiomt - the MT means MethodTree. See more comments below
1890 ;; for the rest of the eieiomt methods.
1891
1892 ;; Collect lambda expressions stored for the class and its parent
1893 ;; classes.
1894 (let (lambdas)
1895 (dolist (ancestor (eieio-class-precedence-list class))
1896 ;; Lookup the form to use for the PRIMARY object for the next level
1897 (let ((tmpl (eieio-generic-form method key ancestor)))
1898 (when (and tmpl
1899 (or (not lambdas)
1900 ;; This prevents duplicates coming out of the
1901 ;; class method optimizer. Perhaps we should
1902 ;; just not optimize before/afters?
1903 (not (member tmpl lambdas))))
1904 (push tmpl lambdas))))
1905
1906 ;; Return collected lambda. For :after methods, return in current
1907 ;; order (most general class last); Otherwise, reverse order.
1908 (if (eq key method-after)
1909 lambdas
1910 (nreverse lambdas))))
1911
1912
1913;;;
1914;; eieio-method-tree : eieiomt-
1915;;
1916;; Stored as eieio-method-tree in property list of a generic method
1917;;
1918;; (eieio-method-tree . [BEFORE PRIMARY AFTER
1919;; genericBEFORE genericPRIMARY genericAFTER])
1920;; and
1921;; (eieio-method-obarray . [BEFORE PRIMARY AFTER
1922;; genericBEFORE genericPRIMARY genericAFTER])
1923;; where the association is a vector.
1924;; (aref 0 -- all static methods.
1925;; (aref 1 -- all methods classified as :before
1926;; (aref 2 -- all methods classified as :primary
1927;; (aref 3 -- all methods classified as :after
1928;; (aref 4 -- a generic classified as :before
1929;; (aref 5 -- a generic classified as :primary
1930;; (aref 6 -- a generic classified as :after
1931;;
1932(defvar eieiomt-optimizing-obarray nil
1933 "While mapping atoms, this contain the obarray being optimized.")
1934
1935(defun eieiomt-install (method-name)
1936 "Install the method tree, and obarray onto METHOD-NAME.
1937Do not do the work if they already exist."
1938 (let ((emtv (get method-name 'eieio-method-tree))
1939 (emto (get method-name 'eieio-method-obarray)))
1940 (if (or (not emtv) (not emto))
1941 (progn
1942 (setq emtv (put method-name 'eieio-method-tree
1943 (make-vector method-num-slots nil))
1944 emto (put method-name 'eieio-method-obarray
1945 (make-vector method-num-slots nil)))
1946 (aset emto 0 (make-vector 11 0))
1947 (aset emto 1 (make-vector 11 0))
1948 (aset emto 2 (make-vector 41 0))
1949 (aset emto 3 (make-vector 11 0))
1950 ))))
1951
1952(defun eieiomt-add (method-name method key class)
1953 "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS.
1954METHOD-NAME is the name created by a call to `defgeneric'.
1955METHOD are the forms for a given implementation.
1956KEY is an integer (see comment in eieio.el near this function) which
1957is associated with the :static :before :primary and :after tags.
1958It also indicates if CLASS is defined or not.
1959CLASS is the class this method is associated with."
1960 (if (or (> key method-num-slots) (< key 0))
1961 (error "eieiomt-add: method key error!"))
1962 (let ((emtv (get method-name 'eieio-method-tree))
1963 (emto (get method-name 'eieio-method-obarray)))
1964 ;; Make sure the method tables are available.
1965 (if (or (not emtv) (not emto))
1966 (error "Programmer error: eieiomt-add"))
1967 ;; only add new cells on if it doesn't already exist!
1968 (if (assq class (aref emtv key))
1969 (setcdr (assq class (aref emtv key)) method)
1970 (aset emtv key (cons (cons class method) (aref emtv key))))
1971 ;; Add function definition into newly created symbol, and store
1972 ;; said symbol in the correct obarray, otherwise use the
1973 ;; other array to keep this stuff
1974 (if (< key method-num-lists)
1975 (let ((nsym (intern (symbol-name class) (aref emto key))))
1976 (fset nsym method)))
1977 ;; Save the defmethod file location in a symbol property.
1978 (let ((fname (if load-in-progress
1979 load-file-name
1980 buffer-file-name))
1981 loc)
1982 (when fname
1983 (when (string-match "\\.elc$" fname)
1984 (setq fname (substring fname 0 (1- (length fname)))))
1985 (setq loc (get method-name 'method-locations))
1986 (cl-pushnew (list class fname) loc :test 'equal)
1987 (put method-name 'method-locations loc)))
1988 ;; Now optimize the entire obarray
1989 (if (< key method-num-lists)
1990 (let ((eieiomt-optimizing-obarray (aref emto key)))
1991 ;; @todo - Is this overkill? Should we just clear the symbol?
1992 (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray)))
1993 ))
1994
1995(defun eieiomt-next (class)
1996 "Return the next parent class for CLASS.
1997If CLASS is a superclass, return variable `eieio-default-superclass'.
1998If CLASS is variable `eieio-default-superclass' then return nil.
1999This is different from function `class-parent' as class parent returns
2000nil for superclasses. This function performs no type checking!"
2001 ;; No type-checking because all calls are made from functions which
2002 ;; are safe and do checking for us.
2003 (or (eieio-class-parents-fast class)
2004 (if (eq class 'eieio-default-superclass)
2005 nil
2006 '(eieio-default-superclass))))
2007
2008(defun eieiomt-sym-optimize (s)
2009 "Find the next class above S which has a function body for the optimizer."
2010 ;; Set the value to nil in case there is no nearest cell.
2011 (set s nil)
2012 ;; Find the nearest cell that has a function body. If we find one,
2013 ;; we replace the nil from above.
2014 (let ((external-symbol (intern-soft (symbol-name s))))
2015 (catch 'done
2016 (dolist (ancestor
2017 (cl-rest (eieio-class-precedence-list external-symbol)))
2018 (let ((ov (intern-soft (symbol-name ancestor)
2019 eieiomt-optimizing-obarray)))
2020 (when (fboundp ov)
2021 (set s ov) ;; store ov as our next symbol
2022 (throw 'done ancestor)))))))
2023
2024(defun eieio-generic-form (method key class)
2025 "Return the lambda form belonging to METHOD using KEY based upon CLASS.
2026If CLASS is not a class then use `generic' instead. If class has
2027no form, but has a parent class, then trace to that parent class.
2028The first time a form is requested from a symbol, an optimized path
2029is memorized for faster future use."
2030 (let ((emto (aref (get method 'eieio-method-obarray)
2031 (if class key (eieio-specialized-key-to-generic-key key)))))
2032 (if (class-p class)
2033 ;; 1) find our symbol
2034 (let ((cs (intern-soft (symbol-name class) emto)))
2035 (if (not cs)
2036 ;; 2) If there isn't one, then make one.
2037 ;; This can be slow since it only occurs once
2038 (progn
2039 (setq cs (intern (symbol-name class) emto))
2040 ;; 2.1) Cache its nearest neighbor with a quick optimize
2041 ;; which should only occur once for this call ever
2042 (let ((eieiomt-optimizing-obarray emto))
2043 (eieiomt-sym-optimize cs))))
2044 ;; 3) If it's bound return this one.
2045 (if (fboundp cs)
2046 (cons cs (eieio--class-symbol (class-v class)))
2047 ;; 4) If it's not bound then this variable knows something
2048 (if (symbol-value cs)
2049 (progn
2050 ;; 4.1) This symbol holds the next class in its value
2051 (setq class (symbol-value cs)
2052 cs (intern-soft (symbol-name class) emto))
2053 ;; 4.2) The optimizer should always have chosen a
2054 ;; function-symbol
2055 ;;(if (fboundp cs)
2056 (cons cs (eieio--class-symbol (class-v (intern (symbol-name class)))))
2057 ;;(error "EIEIO optimizer: erratic data loss!"))
2058 )
2059 ;; There never will be a funcall...
2060 nil)))
2061 ;; for a generic call, what is a list, is the function body we want.
2062 (let ((emtl (aref (get method 'eieio-method-tree)
2063 (if class key (eieio-specialized-key-to-generic-key key)))))
2064 (if emtl
2065 ;; The car of EMTL is supposed to be a class, which in this
2066 ;; case is nil, so skip it.
2067 (cons (cdr (car emtl)) nil)
2068 nil)))))
2069 1297
2070 1298
2071;;; Here are some special types of errors 1299;;; Here are some special types of errors
2072;; 1300;;
2073(define-error 'no-method-definition "No method definition")
2074(define-error 'no-next-method "No next method")
2075(define-error 'invalid-slot-name "Invalid slot name") 1301(define-error 'invalid-slot-name "Invalid slot name")
2076(define-error 'invalid-slot-type "Invalid slot type") 1302(define-error 'invalid-slot-type "Invalid slot type")
2077(define-error 'unbound-slot "Unbound slot") 1303(define-error 'unbound-slot "Unbound slot")
2078(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") 1304(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
2079 1305
2080;;; Obsolete backward compatibility functions. 1306;;; Backward compatibility functions
2081;; Needed to run byte-code compiled with the EIEIO of Emacs-23. 1307;; To support .elc files compiled for older versions of EIEIO.
2082 1308
2083(defun eieio-defmethod (method args) 1309(defun eieio-defclass (cname superclasses slots options)
2084 "Obsolete work part of an old version of the `defmethod' macro." 1310 (eval `(defclass ,cname ,superclasses ,slots ,options)))
2085 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) 1311
2086 ;; find optional keys
2087 (setq key
2088 (cond ((memq (car args) '(:BEFORE :before))
2089 (setq args (cdr args))
2090 method-before)
2091 ((memq (car args) '(:AFTER :after))
2092 (setq args (cdr args))
2093 method-after)
2094 ((memq (car args) '(:STATIC :static))
2095 (setq args (cdr args))
2096 method-static)
2097 ((memq (car args) '(:PRIMARY :primary))
2098 (setq args (cdr args))
2099 method-primary)
2100 ;; Primary key.
2101 (t method-primary)))
2102 ;; Get body, and fix contents of args to be the arguments of the fn.
2103 (setq body (cdr args)
2104 args (car args))
2105 (setq loopa args)
2106 ;; Create a fixed version of the arguments.
2107 (while loopa
2108 (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
2109 argfix))
2110 (setq loopa (cdr loopa)))
2111 ;; Make sure there is a generic.
2112 (eieio-defgeneric
2113 method
2114 (if (stringp (car body))
2115 (car body) (format "Generically created method `%s'." method)))
2116 ;; create symbol for property to bind to. If the first arg is of
2117 ;; the form (varname vartype) and `vartype' is a class, then
2118 ;; that class will be the type symbol. If not, then it will fall
2119 ;; under the type `primary' which is a non-specific calling of the
2120 ;; function.
2121 (setq firstarg (car args))
2122 (if (listp firstarg)
2123 (progn
2124 (setq argclass (nth 1 firstarg))
2125 (if (not (class-p argclass))
2126 (error "Unknown class type %s in method parameters"
2127 (nth 1 firstarg))))
2128 ;; Generics are higher.
2129 (setq key (eieio-specialized-key-to-generic-key key)))
2130 ;; Put this lambda into the symbol so we can find it.
2131 (if (byte-code-function-p (car-safe body))
2132 (eieiomt-add method (car-safe body) key argclass)
2133 (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
2134 key argclass))
2135 )
2136
2137 (when eieio-optimize-primary-methods-flag
2138 ;; Optimizing step:
2139 ;;
2140 ;; If this method, after this setup, only has primary methods, then
2141 ;; we can setup the generic that way.
2142 (if (generic-primary-only-p method)
2143 ;; If there is only one primary method, then we can go one more
2144 ;; optimization step.
2145 (if (generic-primary-only-one-p method)
2146 (eieio-defgeneric-reset-generic-form-primary-only-one method)
2147 (eieio-defgeneric-reset-generic-form-primary-only method))
2148 (eieio-defgeneric-reset-generic-form method)))
2149
2150 method)
2151(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
2152
2153(defun eieio-defgeneric (method doc-string)
2154 "Obsolete work part of an old version of the `defgeneric' macro."
2155 (if (and (fboundp method) (not (generic-p method))
2156 (or (byte-code-function-p (symbol-function method))
2157 (not (eq 'autoload (car (symbol-function method)))))
2158 )
2159 (error "You cannot create a generic/method over an existing symbol: %s"
2160 method))
2161 ;; Don't do this over and over.
2162 (unless (fboundp 'method)
2163 ;; This defun tells emacs where the first definition of this
2164 ;; method is defined.
2165 `(defun ,method nil)
2166 ;; Make sure the method tables are installed.
2167 (eieiomt-install method)
2168 ;; Apply the actual body of this function.
2169 (fset method (eieio-defgeneric-form method doc-string))
2170 ;; Return the method
2171 'method))
2172(make-obsolete 'eieio-defgeneric nil "24.1")
2173 1312
2174(provide 'eieio-core) 1313(provide 'eieio-core)
2175 1314
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index dc85b4cc892..d0eaaf24d2b 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -1,4 +1,4 @@
1;;; eieio-custom.el -- eieio object customization 1;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation, 3;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation,
4;; Inc. 4;; Inc.
@@ -70,7 +70,7 @@ of these.")
70 :documentation "A number of thingies.")) 70 :documentation "A number of thingies."))
71 "A class for testing the widget on.") 71 "A class for testing the widget on.")
72 72
73(defcustom eieio-widget-test (eieio-widget-test-class "Foo") 73(defcustom eieio-widget-test (eieio-widget-test-class)
74 "Test variable for editing an object." 74 "Test variable for editing an object."
75 :type 'object 75 :type 'object
76 :group 'eieio) 76 :group 'eieio)
@@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.")
136 )) 136 ))
137 (widget-value-set vc (widget-value vc)))) 137 (widget-value-set vc (widget-value vc))))
138 138
139(defun eieio-custom-toggle-parent (widget &rest ignore) 139(defun eieio-custom-toggle-parent (widget &rest _)
140 "Toggle visibility of parent of WIDGET. 140 "Toggle visibility of parent of WIDGET.
141Optional argument IGNORE is an extraneous parameter." 141Optional argument IGNORE is an extraneous parameter."
142 (eieio-custom-toggle-hide (widget-get widget :parent))) 142 (eieio-custom-toggle-hide (widget-get widget :parent)))
@@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter."
154 :clone-object-children nil 154 :clone-object-children nil
155 ) 155 )
156 156
157(defun eieio-object-match (widget value) 157(defun eieio-object-match (_widget _value)
158 "Match info for WIDGET against VALUE." 158 "Match info for WIDGET against VALUE."
159 ;; Write me 159 ;; Write me
160 t) 160 t)
@@ -193,7 +193,7 @@ Optional argument IGNORE is an extraneous parameter."
193 (let* ((chil nil) 193 (let* ((chil nil)
194 (obj (widget-get widget :value)) 194 (obj (widget-get widget :value))
195 (master-group (widget-get widget :eieio-group)) 195 (master-group (widget-get widget :eieio-group))
196 (cv (class-v (eieio--object-class obj))) 196 (cv (eieio--object-class-object obj))
197 (slots (eieio--class-public-a cv)) 197 (slots (eieio--class-public-a cv))
198 (flabel (eieio--class-public-custom-label cv)) 198 (flabel (eieio--class-public-custom-label cv))
199 (fgroup (eieio--class-public-custom-group cv)) 199 (fgroup (eieio--class-public-custom-group cv))
@@ -208,7 +208,8 @@ Optional argument IGNORE is an extraneous parameter."
208 chil))) 208 chil)))
209 ;; Display information about the group being shown 209 ;; Display information about the group being shown
210 (when master-group 210 (when master-group
211 (let ((groups (class-option (eieio--object-class obj) :custom-groups))) 211 (let ((groups (eieio--class-option (eieio--object-class-object obj)
212 :custom-groups)))
212 (widget-insert "Groups:") 213 (widget-insert "Groups:")
213 (while groups 214 (while groups
214 (widget-insert " ") 215 (widget-insert " ")
@@ -216,7 +217,7 @@ Optional argument IGNORE is an extraneous parameter."
216 (widget-insert "*" (capitalize (symbol-name master-group)) "*") 217 (widget-insert "*" (capitalize (symbol-name master-group)) "*")
217 (widget-create 'push-button 218 (widget-create 'push-button
218 :thing (cons obj (car groups)) 219 :thing (cons obj (car groups))
219 :notify (lambda (widget &rest stuff) 220 :notify (lambda (widget &rest _)
220 (eieio-customize-object 221 (eieio-customize-object
221 (car (widget-get widget :thing)) 222 (car (widget-get widget :thing))
222 (cdr (widget-get widget :thing)))) 223 (cdr (widget-get widget :thing))))
@@ -260,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter."
260 (car flabel) 261 (car flabel)
261 (let ((s (symbol-name 262 (let ((s (symbol-name
262 (or 263 (or
263 (class-slot-initarg 264 (eieio--class-slot-initarg
264 (eieio--object-class obj) 265 (eieio--object-class-object obj)
265 (car slots)) 266 (car slots))
266 (car slots))))) 267 (car slots)))))
267 (capitalize 268 (capitalize
@@ -288,7 +289,7 @@ Optional argument IGNORE is an extraneous parameter."
288 "Get the value of WIDGET." 289 "Get the value of WIDGET."
289 (let* ((obj (widget-get widget :value)) 290 (let* ((obj (widget-get widget :value))
290 (master-group eieio-cog) 291 (master-group eieio-cog)
291 (cv (class-v (eieio--object-class obj))) 292 (cv (eieio--object-class-object obj))
292 (fgroup (eieio--class-public-custom-group cv)) 293 (fgroup (eieio--class-public-custom-group cv))
293 (wids (widget-get widget :children)) 294 (wids (widget-get widget :children))
294 (name (if (widget-get widget :eieio-show-name) 295 (name (if (widget-get widget :eieio-show-name)
@@ -296,7 +297,7 @@ Optional argument IGNORE is an extraneous parameter."
296 nil)) 297 nil))
297 (chil (if (widget-get widget :eieio-show-name) 298 (chil (if (widget-get widget :eieio-show-name)
298 (nthcdr 1 wids) wids)) 299 (nthcdr 1 wids) wids))
299 (cv (class-v (eieio--object-class obj))) 300 (cv (eieio--object-class-object obj))
300 (slots (eieio--class-public-a cv)) 301 (slots (eieio--class-public-a cv))
301 (fcust (eieio--class-public-custom cv))) 302 (fcust (eieio--class-public-custom cv)))
302 ;; If there are any prefix widgets, clear them. 303 ;; If there are any prefix widgets, clear them.
@@ -317,11 +318,11 @@ Optional argument IGNORE is an extraneous parameter."
317 fgroup (cdr fgroup) 318 fgroup (cdr fgroup)
318 fcust (cdr fcust))) 319 fcust (cdr fcust)))
319 ;; Set any name updates on it. 320 ;; Set any name updates on it.
320 (if name (setf (eieio--object-name obj) name)) 321 (if name (eieio-object-set-name-string obj name))
321 ;; This is the same object we had before. 322 ;; This is the same object we had before.
322 obj)) 323 obj))
323 324
324(defmethod eieio-done-customizing ((obj eieio-default-superclass)) 325(defmethod eieio-done-customizing ((_obj eieio-default-superclass))
325 "When applying change to a widget, call this method. 326 "When applying change to a widget, call this method.
326This method is called by the default widget-edit commands. 327This method is called by the default widget-edit commands.
327User made commands should also call this method when applying changes. 328User made commands should also call this method when applying changes.
@@ -385,18 +386,18 @@ These groups are specified with the `:group' slot flag."
385 (make-local-variable 'eieio-cog) 386 (make-local-variable 'eieio-cog)
386 (setq eieio-cog g))) 387 (setq eieio-cog g)))
387 388
388(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) 389(defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
389 "Insert an Apply and Reset button into the object editor. 390 "Insert an Apply and Reset button into the object editor.
390Argument OBJ is the object being customized." 391Argument OBJ is the object being customized."
391 (widget-create 'push-button 392 (widget-create 'push-button
392 :notify (lambda (&rest ignore) 393 :notify (lambda (&rest _)
393 (widget-apply eieio-wo :value-get) 394 (widget-apply eieio-wo :value-get)
394 (eieio-done-customizing eieio-co) 395 (eieio-done-customizing eieio-co)
395 (bury-buffer)) 396 (bury-buffer))
396 "Accept") 397 "Accept")
397 (widget-insert " ") 398 (widget-insert " ")
398 (widget-create 'push-button 399 (widget-create 'push-button
399 :notify (lambda (&rest ignore) 400 :notify (lambda (&rest _)
400 ;; I think the act of getting it sets 401 ;; I think the act of getting it sets
401 ;; its value through the get function. 402 ;; its value through the get function.
402 (message "Applying Changes...") 403 (message "Applying Changes...")
@@ -406,13 +407,13 @@ Argument OBJ is the object being customized."
406 "Apply") 407 "Apply")
407 (widget-insert " ") 408 (widget-insert " ")
408 (widget-create 'push-button 409 (widget-create 'push-button
409 :notify (lambda (&rest ignore) 410 :notify (lambda (&rest _)
410 (message "Resetting") 411 (message "Resetting")
411 (eieio-customize-object eieio-co eieio-cog)) 412 (eieio-customize-object eieio-co eieio-cog))
412 "Reset") 413 "Reset")
413 (widget-insert " ") 414 (widget-insert " ")
414 (widget-create 'push-button 415 (widget-create 'push-button
415 :notify (lambda (&rest ignore) 416 :notify (lambda (&rest _)
416 (bury-buffer)) 417 (bury-buffer))
417 "Cancel")) 418 "Cancel"))
418 419
@@ -431,13 +432,11 @@ Must return the created widget."
431 :clone-object-children t 432 :clone-object-children t
432 ) 433 )
433 434
434(defun eieio-object-value-to-abstract (widget value) 435(defun eieio-object-value-to-abstract (_widget value)
435 "For WIDGET, convert VALUE to an abstract /safe/ representation." 436 "For WIDGET, convert VALUE to an abstract /safe/ representation."
436 (if (eieio-object-p value) value 437 (if (eieio-object-p value) value))
437 (if (null value) value
438 nil)))
439 438
440(defun eieio-object-abstract-to-value (widget value) 439(defun eieio-object-abstract-to-value (_widget value)
441 "For WIDGET, convert VALUE from an abstract /safe/ representation." 440 "For WIDGET, convert VALUE from an abstract /safe/ representation."
442 value) 441 value)
443 442
@@ -453,7 +452,7 @@ Must return the created widget."
453 (vector (concat "Group " (symbol-name group)) 452 (vector (concat "Group " (symbol-name group))
454 (list 'customize-object obj (list 'quote group)) 453 (list 'customize-object obj (list 'quote group))
455 t)) 454 t))
456 (class-option (eieio--object-class obj) :custom-groups))) 455 (eieio--class-option (eieio--object-class-object obj) :custom-groups)))
457 456
458(defvar eieio-read-custom-group-history nil 457(defvar eieio-read-custom-group-history nil
459 "History for the custom group reader.") 458 "History for the custom group reader.")
@@ -461,7 +460,8 @@ Must return the created widget."
461(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) 460(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
462 "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.
463Return the symbol for the group, or nil" 462Return the symbol for the group, or nil"
464 (let ((g (class-option (eieio--object-class obj) :custom-groups))) 463 (let ((g (eieio--class-option (eieio--object-class-object obj)
464 :custom-groups)))
465 (if (= (length g) 1) 465 (if (= (length g) 1)
466 (car g) 466 (car g)
467 ;; Make the association list 467 ;; Make the association list
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index 0a51ecfa203..43d9a03932a 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -1,4 +1,4 @@
1;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. 1;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2007-2015 Free Software Foundation, Inc. 3;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
4 4
@@ -87,7 +87,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
87 prefix 87 prefix
88 "Name: ") 88 "Name: ")
89 (let* ((cl (eieio-object-class obj)) 89 (let* ((cl (eieio-object-class obj))
90 (cv (class-v cl))) 90 (cv (eieio--class-v cl)))
91 (data-debug-insert-thing (class-constructor cl) 91 (data-debug-insert-thing (class-constructor cl)
92 prefix 92 prefix
93 "Class: ") 93 "Class: ")
@@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
96 ) 96 )
97 (while publa 97 (while publa
98 (if (slot-boundp obj (car publa)) 98 (if (slot-boundp obj (car publa))
99 (let* ((i (class-slot-initarg cl (car publa))) 99 (let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
100 (car publa)))
100 (v (eieio-oref obj (car publa)))) 101 (v (eieio-oref obj (car publa))))
101 (data-debug-insert-thing 102 (data-debug-insert-thing
102 v prefix (concat 103 v prefix (concat
@@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
104 (symbol-name (car publa))) 105 (symbol-name (car publa)))
105 " "))) 106 " ")))
106 ;; Unbound case 107 ;; Unbound case
107 (let ((i (class-slot-initarg cl (car publa)))) 108 (let ((i (eieio--class-slot-initarg (eieio--class-v cl)
109 (car publa))))
108 (data-debug-insert-custom 110 (data-debug-insert-custom
109 "#unbound" prefix 111 "#unbound" prefix
110 (concat (if i (symbol-name i) 112 (concat (if i (symbol-name i)
@@ -135,9 +137,9 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
135 (let* ((eieio-pre-method-execution-functions 137 (let* ((eieio-pre-method-execution-functions
136 (lambda (l) (throw 'moose l) )) 138 (lambda (l) (throw 'moose l) ))
137 (data 139 (data
138 (catch 'moose (eieio-generic-call 140 (catch 'moose (eieio--generic-call
139 method (list class)))) 141 method (list class))))
140 (buf (data-debug-new-buffer "*Method Invocation*")) 142 (_buf (data-debug-new-buffer "*Method Invocation*"))
141 (data2 (mapcar (lambda (sym) 143 (data2 (mapcar (lambda (sym)
142 (symbol-function (car sym))) 144 (symbol-function (car sym)))
143 data))) 145 data)))
diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el
new file mode 100644
index 00000000000..0e90074660e
--- /dev/null
+++ b/lisp/emacs-lisp/eieio-generic.el
@@ -0,0 +1,904 @@
1;;; eieio-generic.el --- CLOS-style generics for EIEIO -*- lexical-binding:t -*-
2
3;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Keywords: OO, lisp
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; The "core" part of EIEIO is the implementation for the object
26;; system (such as eieio-defclass, or eieio-defmethod) but not the
27;; base classes for the object system, which are defined in EIEIO.
28;;
29;; See the commentary for eieio.el for more about EIEIO itself.
30
31;;; Code:
32
33(require 'eieio-core)
34(declare-function child-of-class-p "eieio")
35
36(defconst eieio--method-static 0 "Index into :static tag on a method.")
37(defconst eieio--method-before 1 "Index into :before tag on a method.")
38(defconst eieio--method-primary 2 "Index into :primary tag on a method.")
39(defconst eieio--method-after 3 "Index into :after tag on a method.")
40(defconst eieio--method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.")
41(defconst eieio--method-generic-before 4 "Index into generic :before tag on a method.")
42(defconst eieio--method-generic-primary 5 "Index into generic :primary tag on a method.")
43(defconst eieio--method-generic-after 6 "Index into generic :after tag on a method.")
44(defconst eieio--method-num-slots 7 "Number of indexes into a method's vector.")
45
46(defsubst eieio--specialized-key-to-generic-key (key)
47 "Convert a specialized KEY into a generic method key."
48 (cond ((eq key eieio--method-static) 0) ;; don't convert
49 ((< key eieio--method-num-lists) (+ key 3)) ;; The conversion
50 (t key) ;; already generic.. maybe.
51 ))
52
53
54(defsubst generic-p (method)
55 "Return non-nil if symbol METHOD is a generic function.
56Only methods have the symbol `eieio-method-hashtable' as a property
57\(which contains a list of all bindings to that method type.)"
58 (and (fboundp method) (get method 'eieio-method-hashtable)))
59
60(defun eieio--generic-primary-only-p (method)
61 "Return t if symbol METHOD is a generic function with only primary methods.
62Only methods have the symbol `eieio-method-hashtable' as a property (which
63contains a list of all bindings to that method type.)
64Methods with only primary implementations are executed in an optimized way."
65 (and (generic-p method)
66 (let ((M (get method 'eieio-method-tree)))
67 (not (or (>= 0 (length (aref M eieio--method-primary)))
68 (aref M eieio--method-static)
69 (aref M eieio--method-before)
70 (aref M eieio--method-after)
71 (aref M eieio--method-generic-before)
72 (aref M eieio--method-generic-primary)
73 (aref M eieio--method-generic-after)))
74 )))
75
76(defun eieio--generic-primary-only-one-p (method)
77 "Return t if symbol METHOD is a generic function with only primary methods.
78Only methods have the symbol `eieio-method-hashtable' as a property (which
79contains a list of all bindings to that method type.)
80Methods with only primary implementations are executed in an optimized way."
81 (and (generic-p method)
82 (let ((M (get method 'eieio-method-tree)))
83 (not (or (/= 1 (length (aref M eieio--method-primary)))
84 (aref M eieio--method-static)
85 (aref M eieio--method-before)
86 (aref M eieio--method-after)
87 (aref M eieio--method-generic-before)
88 (aref M eieio--method-generic-primary)
89 (aref M eieio--method-generic-after)))
90 )))
91
92(defun eieio--defgeneric-init-form (method doc-string)
93 "Form to use for the initial definition of a generic."
94 (while (and (fboundp method) (symbolp (symbol-function method)))
95 ;; Follow aliases, so methods applied to obsolete aliases still work.
96 (setq method (symbol-function method)))
97
98 (cond
99 ((or (not (fboundp method))
100 (eq 'autoload (car-safe (symbol-function method))))
101 ;; Make sure the method tables are installed.
102 (eieio--mt-install method)
103 ;; Construct the actual body of this function.
104 (put method 'function-documentation doc-string)
105 (eieio--defgeneric-form method))
106 ((generic-p method) (symbol-function method)) ;Leave it as-is.
107 (t (error "You cannot create a generic/method over an existing symbol: %s"
108 method))))
109
110(defun eieio--defgeneric-form (method)
111 "The lambda form that would be used as the function defined on METHOD.
112All methods should call the same EIEIO function for dispatch.
113DOC-STRING is the documentation attached to METHOD."
114 (lambda (&rest local-args)
115 (eieio--generic-call method local-args)))
116
117(defun eieio--defgeneric-form-primary-only (method)
118 "The lambda form that would be used as the function defined on METHOD.
119All methods should call the same EIEIO function for dispatch.
120DOC-STRING is the documentation attached to METHOD."
121 (lambda (&rest local-args)
122 (eieio--generic-call-primary-only method local-args)))
123
124(defvar eieio--generic-call-arglst nil
125 "When using `call-next-method', provides a context for parameters.")
126(defvar eieio--generic-call-key nil
127 "When using `call-next-method', provides a context for the current key.
128Keys are a number representing :before, :primary, and :after methods.")
129(defvar eieio--generic-call-next-method-list nil
130 "When executing a PRIMARY or STATIC method, track the 'next-method'.
131During executions, the list is first generated, then as each next method
132is called, the next method is popped off the stack.")
133
134(defun eieio--defgeneric-form-primary-only-one (method class impl)
135 "The lambda form that would be used as the function defined on METHOD.
136All methods should call the same EIEIO function for dispatch.
137CLASS is the class symbol needed for private method access.
138IMPL is the symbol holding the method implementation."
139 (lambda (&rest local-args)
140 ;; This is a cool cheat. Usually we need to look up in the
141 ;; method table to find out if there is a method or not. We can
142 ;; instead make that determination at load time when there is
143 ;; only one method. If the first arg is not a child of the class
144 ;; of that one implementation, then clearly, there is no method def.
145 (if (not (eieio-object-p (car local-args)))
146 ;; Not an object. Just signal.
147 (signal 'no-method-definition
148 (list method local-args))
149
150 ;; We do have an object. Make sure it is the right type.
151 (if (not (child-of-class-p (eieio--object-class-object (car local-args))
152 class))
153
154 ;; If not the right kind of object, call no applicable
155 (apply #'no-applicable-method (car local-args)
156 method local-args)
157
158 ;; It is ok, do the call.
159 ;; Fill in inter-call variables then evaluate the method.
160 (let ((eieio--generic-call-next-method-list nil)
161 (eieio--generic-call-key eieio--method-primary)
162 (eieio--generic-call-arglst local-args)
163 )
164 (eieio--with-scoped-class (eieio--class-v class)
165 (apply impl local-args)))))))
166
167(defun eieio-unbind-method-implementations (method)
168 "Make the generic method METHOD have no implementations.
169It will leave the original generic function in place,
170but remove reference to all implementations of METHOD."
171 (put method 'eieio-method-tree nil)
172 (put method 'eieio-method-hashtable nil))
173
174(defun eieio--method-optimize-primary (method)
175 (when eieio-optimize-primary-methods-flag
176 ;; Optimizing step:
177 ;;
178 ;; If this method, after this setup, only has primary methods, then
179 ;; we can setup the generic that way.
180 (let ((doc-string (documentation method 'raw)))
181 (put method 'function-documentation doc-string)
182 ;; Use `defalias' so as to interact properly with nadvice.el.
183 (defalias method
184 (if (eieio--generic-primary-only-p method)
185 ;; If there is only one primary method, then we can go one more
186 ;; optimization step.
187 (if (eieio--generic-primary-only-one-p method)
188 (let* ((M (get method 'eieio-method-tree))
189 (entry (car (aref M eieio--method-primary))))
190 (eieio--defgeneric-form-primary-only-one
191 method (car entry) (cdr entry)))
192 (eieio--defgeneric-form-primary-only method))
193 (eieio--defgeneric-form method))))))
194
195(defun eieio--defmethod (method kind argclass code)
196 "Work part of the `defmethod' macro defining METHOD with ARGS."
197 (let ((key
198 ;; Find optional keys.
199 (cond ((memq kind '(:BEFORE :before)) eieio--method-before)
200 ((memq kind '(:AFTER :after)) eieio--method-after)
201 ((memq kind '(:STATIC :static)) eieio--method-static)
202 ((memq kind '(:PRIMARY :primary nil)) eieio--method-primary)
203 ;; Primary key.
204 ;; (t eieio--method-primary)
205 (t (error "Unknown method kind %S" kind)))))
206
207 (while (and (fboundp method) (symbolp (symbol-function method)))
208 ;; Follow aliases, so methods applied to obsolete aliases still work.
209 (setq method (symbol-function method)))
210
211 ;; Make sure there is a generic (when called from defclass).
212 (eieio--defalias
213 method (eieio--defgeneric-init-form
214 method (or (documentation code)
215 (format "Generically created method `%s'." method))))
216 ;; Create symbol for property to bind to. If the first arg is of
217 ;; the form (varname vartype) and `vartype' is a class, then
218 ;; that class will be the type symbol. If not, then it will fall
219 ;; under the type `primary' which is a non-specific calling of the
220 ;; function.
221 (if argclass
222 (if (not (class-p argclass)) ;FIXME: Accept cl-defstructs!
223 (error "Unknown class type %s in method parameters"
224 argclass))
225 ;; Generics are higher.
226 (setq key (eieio--specialized-key-to-generic-key key)))
227 ;; Put this lambda into the symbol so we can find it.
228 (eieio--mt-add method code key argclass)
229 )
230
231 (eieio--method-optimize-primary method)
232
233 method)
234
235(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks
236 'eieio-pre-method-execution-functions "24.3")
237(defvar eieio-pre-method-execution-functions nil
238 "Abnormal hook run just before an EIEIO method is executed.
239The hook function must accept one argument, the list of forms
240about to be executed.")
241
242(defun eieio--generic-call (method args)
243 "Call METHOD with ARGS.
244ARGS provides the context on which implementation to use.
245This should only be called from a generic function."
246 ;; We must expand our arguments first as they are always
247 ;; passed in as quoted symbols
248 (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil)
249 (eieio--generic-call-arglst args)
250 (firstarg nil)
251 (primarymethodlist nil))
252 ;; get a copy
253 (setq newargs args
254 firstarg (car newargs))
255 ;; Is the class passed in autoloaded?
256 ;; Since class names are also constructors, they can be autoloaded
257 ;; via the autoload command. Check for this, and load them in.
258 ;; It is ok if it doesn't turn out to be a class. Probably want that
259 ;; function loaded anyway.
260 (if (and (symbolp firstarg)
261 (fboundp firstarg)
262 (autoloadp (symbol-function firstarg)))
263 (autoload-do-load (symbol-function firstarg)))
264 ;; Determine the class to use.
265 (cond ((eieio-object-p firstarg)
266 (setq mclass (eieio--object-class-name firstarg)))
267 ((class-p firstarg)
268 (setq mclass firstarg))
269 )
270 ;; Make sure the class is a valid class
271 ;; mclass can be nil (meaning a generic for should be used.
272 ;; mclass cannot have a value that is not a class, however.
273 (unless (or (null mclass) (class-p mclass))
274 (error "Cannot dispatch method %S on class %S"
275 method mclass)
276 )
277 ;; Now create a list in reverse order of all the calls we have
278 ;; make in order to successfully do this right. Rules:
279 ;; 1) Only call generics if scoped-class is not defined
280 ;; This prevents multiple calls in the case of recursion
281 ;; 2) Only call static if this is a static method.
282 ;; 3) Only call specifics if the definition allows for them.
283 ;; 4) Call in order based on :before, :primary, and :after
284 (when (eieio-object-p firstarg)
285 ;; Non-static calls do all this stuff.
286
287 ;; :after methods
288 (setq tlambdas
289 (if mclass
290 (eieio--mt-method-list method eieio--method-after mclass)
291 (list (eieio--generic-form method eieio--method-after nil)))
292 ;;(or (and mclass (eieio--generic-form method eieio--method-after mclass))
293 ;; (eieio--generic-form method eieio--method-after nil))
294 )
295 (setq lambdas (append tlambdas lambdas)
296 keys (append (make-list (length tlambdas) eieio--method-after) keys))
297
298 ;; :primary methods
299 (setq tlambdas
300 (or (and mclass (eieio--generic-form method eieio--method-primary mclass))
301 (eieio--generic-form method eieio--method-primary nil)))
302 (when tlambdas
303 (setq lambdas (cons tlambdas lambdas)
304 keys (cons eieio--method-primary keys)
305 primarymethodlist
306 (eieio--mt-method-list method eieio--method-primary mclass)))
307
308 ;; :before methods
309 (setq tlambdas
310 (if mclass
311 (eieio--mt-method-list method eieio--method-before mclass)
312 (list (eieio--generic-form method eieio--method-before nil)))
313 ;;(or (and mclass (eieio--generic-form method eieio--method-before mclass))
314 ;; (eieio--generic-form method eieio--method-before nil))
315 )
316 (setq lambdas (append tlambdas lambdas)
317 keys (append (make-list (length tlambdas) eieio--method-before) keys))
318 )
319
320 (if mclass
321 ;; For the case of a class,
322 ;; if there were no methods found, then there could be :static methods.
323 (when (not lambdas)
324 (setq tlambdas
325 (eieio--generic-form method eieio--method-static mclass))
326 (setq lambdas (cons tlambdas lambdas)
327 keys (cons eieio--method-static keys)
328 primarymethodlist ;; Re-use even with bad name here
329 (eieio--mt-method-list method eieio--method-static mclass)))
330 ;; For the case of no class (ie - mclass == nil) then there may
331 ;; be a primary method.
332 (setq tlambdas
333 (eieio--generic-form method eieio--method-primary nil))
334 (when tlambdas
335 (setq lambdas (cons tlambdas lambdas)
336 keys (cons eieio--method-primary keys)
337 primarymethodlist
338 (eieio--mt-method-list method eieio--method-primary nil)))
339 )
340
341 (run-hook-with-args 'eieio-pre-method-execution-functions
342 primarymethodlist)
343
344 ;; Now loop through all occurrences forms which we must execute
345 ;; (which are happily sorted now) and execute them all!
346 (let ((rval nil) (lastval nil) (found nil))
347 (while lambdas
348 (if (car lambdas)
349 (eieio--with-scoped-class (cdr (car lambdas))
350 (let* ((eieio--generic-call-key (car keys))
351 (has-return-val
352 (or (= eieio--generic-call-key eieio--method-primary)
353 (= eieio--generic-call-key eieio--method-static)))
354 (eieio--generic-call-next-method-list
355 ;; Use the cdr, as the first element is the fcn
356 ;; we are calling right now.
357 (when has-return-val (cdr primarymethodlist)))
358 )
359 (setq found t)
360 ;;(setq rval (apply (car (car lambdas)) newargs))
361 (setq lastval (apply (car (car lambdas)) newargs))
362 (when has-return-val
363 (setq rval lastval))
364 )))
365 (setq lambdas (cdr lambdas)
366 keys (cdr keys)))
367 (if (not found)
368 (if (eieio-object-p (car args))
369 (setq rval (apply #'no-applicable-method (car args) method args))
370 (signal
371 'no-method-definition
372 (list method args))))
373 rval)))
374
375(defun eieio--generic-call-primary-only (method args)
376 "Call METHOD with ARGS for methods with only :PRIMARY implementations.
377ARGS provides the context on which implementation to use.
378This should only be called from a generic function.
379
380This method is like `eieio--generic-call', but only
381implementations in the :PRIMARY slot are queried. After many
382years of use, it appears that over 90% of methods in use
383have :PRIMARY implementations only. We can therefore optimize
384for this common case to improve performance."
385 ;; We must expand our arguments first as they are always
386 ;; passed in as quoted symbols
387 (let ((newargs nil) (mclass nil) (lambdas nil)
388 (eieio--generic-call-arglst args)
389 (firstarg nil)
390 (primarymethodlist nil)
391 )
392 ;; get a copy
393 (setq newargs args
394 firstarg (car newargs))
395
396 ;; Determine the class to use.
397 (cond ((eieio-object-p firstarg)
398 (setq mclass (eieio--object-class-name firstarg)))
399 ((not firstarg)
400 (error "Method %s called on nil" method))
401 (t
402 (error "Primary-only method %s called on something not an object" method)))
403 ;; Make sure the class is a valid class
404 ;; mclass can be nil (meaning a generic for should be used.
405 ;; mclass cannot have a value that is not a class, however.
406 (when (null mclass)
407 (error "Cannot dispatch method %S on class %S" method mclass)
408 )
409
410 ;; :primary methods
411 (setq lambdas (eieio--generic-form method eieio--method-primary mclass))
412 (setq primarymethodlist ;; Re-use even with bad name here
413 (eieio--mt-method-list method eieio--method-primary mclass))
414
415 ;; Now loop through all occurrences forms which we must execute
416 ;; (which are happily sorted now) and execute them all!
417 (eieio--with-scoped-class (cdr lambdas)
418 (let* ((rval nil) (lastval nil)
419 (eieio--generic-call-key eieio--method-primary)
420 ;; Use the cdr, as the first element is the fcn
421 ;; we are calling right now.
422 (eieio--generic-call-next-method-list (cdr primarymethodlist))
423 )
424
425 (if (or (not lambdas) (not (car lambdas)))
426
427 ;; No methods found for this impl...
428 (if (eieio-object-p (car args))
429 (setq rval (apply #'no-applicable-method
430 (car args) method args))
431 (signal
432 'no-method-definition
433 (list method args)))
434
435 ;; Do the regular implementation here.
436
437 (run-hook-with-args 'eieio-pre-method-execution-functions
438 lambdas)
439
440 (setq lastval (apply (car lambdas) newargs))
441 (setq rval lastval))
442
443 rval))))
444
445(defun eieio--mt-method-list (method key class)
446 "Return an alist list of methods lambdas.
447METHOD is the method name.
448KEY represents either :before, or :after methods.
449CLASS is the starting class to search from in the method tree.
450If CLASS is nil, then an empty list of methods should be returned."
451 ;; Note: eieiomt - the MT means MethodTree. See more comments below
452 ;; for the rest of the eieiomt methods.
453
454 ;; Collect lambda expressions stored for the class and its parent
455 ;; classes.
456 (let (lambdas)
457 (dolist (ancestor (eieio--class-precedence-list (eieio--class-v class)))
458 ;; Lookup the form to use for the PRIMARY object for the next level
459 (let ((tmpl (eieio--generic-form method key ancestor)))
460 (when (and tmpl
461 (or (not lambdas)
462 ;; This prevents duplicates coming out of the
463 ;; class method optimizer. Perhaps we should
464 ;; just not optimize before/afters?
465 (not (member tmpl lambdas))))
466 (push tmpl lambdas))))
467
468 ;; Return collected lambda. For :after methods, return in current
469 ;; order (most general class last); Otherwise, reverse order.
470 (if (eq key eieio--method-after)
471 lambdas
472 (nreverse lambdas))))
473
474
475;;;
476;; eieio-method-tree : eieio--mt-
477;;
478;; Stored as eieio-method-tree in property list of a generic method
479;;
480;; (eieio-method-tree . [BEFORE PRIMARY AFTER
481;; genericBEFORE genericPRIMARY genericAFTER])
482;; and
483;; (eieio-method-hashtable . [BEFORE PRIMARY AFTER
484;; genericBEFORE genericPRIMARY genericAFTER])
485;; where the association is a vector.
486;; (aref 0 -- all static methods.
487;; (aref 1 -- all methods classified as :before
488;; (aref 2 -- all methods classified as :primary
489;; (aref 3 -- all methods classified as :after
490;; (aref 4 -- a generic classified as :before
491;; (aref 5 -- a generic classified as :primary
492;; (aref 6 -- a generic classified as :after
493;;
494(defvar eieio--mt--optimizing-hashtable nil
495 "While mapping atoms, this contain the hashtable being optimized.")
496
497(defun eieio--mt-install (method-name)
498 "Install the method tree, and hashtable onto METHOD-NAME.
499Do not do the work if they already exist."
500 (unless (and (get method-name 'eieio-method-tree)
501 (get method-name 'eieio-method-hashtable))
502 (put method-name 'eieio-method-tree
503 (make-vector eieio--method-num-slots nil))
504 (let ((emto (put method-name 'eieio-method-hashtable
505 (make-vector eieio--method-num-slots nil))))
506 (aset emto 0 (make-hash-table :test 'eq))
507 (aset emto 1 (make-hash-table :test 'eq))
508 (aset emto 2 (make-hash-table :test 'eq))
509 (aset emto 3 (make-hash-table :test 'eq)))))
510
511(defun eieio--mt-add (method-name method key class)
512 "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS.
513METHOD-NAME is the name created by a call to `defgeneric'.
514METHOD are the forms for a given implementation.
515KEY is an integer (see comment in eieio.el near this function) which
516is associated with the :static :before :primary and :after tags.
517It also indicates if CLASS is defined or not.
518CLASS is the class this method is associated with."
519 (if (or (> key eieio--method-num-slots) (< key 0))
520 (error "eieio--mt-add: method key error!"))
521 (let ((emtv (get method-name 'eieio-method-tree))
522 (emto (get method-name 'eieio-method-hashtable)))
523 ;; Make sure the method tables are available.
524 (unless (and emtv emto)
525 (error "Programmer error: eieio--mt-add"))
526 ;; only add new cells on if it doesn't already exist!
527 (if (assq class (aref emtv key))
528 (setcdr (assq class (aref emtv key)) method)
529 (aset emtv key (cons (cons class method) (aref emtv key))))
530 ;; Add function definition into newly created symbol, and store
531 ;; said symbol in the correct hashtable, otherwise use the
532 ;; other array to keep this stuff.
533 (if (< key eieio--method-num-lists)
534 (puthash (eieio--class-v class) (list method) (aref emto key)))
535 ;; Save the defmethod file location in a symbol property.
536 (let ((fname (if load-in-progress
537 load-file-name
538 buffer-file-name)))
539 (when fname
540 (when (string-match "\\.elc\\'" fname)
541 (setq fname (substring fname 0 (1- (length fname)))))
542 (cl-pushnew (list class fname) (get method-name 'method-locations)
543 :test 'equal)))
544 ;; Now optimize the entire hashtable.
545 (if (< key eieio--method-num-lists)
546 (let ((eieio--mt--optimizing-hashtable (aref emto key)))
547 ;; @todo - Is this overkill? Should we just clear the symbol?
548 (maphash #'eieio--mt--sym-optimize eieio--mt--optimizing-hashtable)))
549 ))
550
551(defun eieio--mt-next (class)
552 "Return the next parent class for CLASS.
553If CLASS is a superclass, return variable `eieio-default-superclass'.
554If CLASS is variable `eieio-default-superclass' then return nil.
555This is different from function `class-parent' as class parent returns
556nil for superclasses. This function performs no type checking!"
557 ;; No type-checking because all calls are made from functions which
558 ;; are safe and do checking for us.
559 (or (eieio--class-parent (eieio--class-v class))
560 (if (eq class 'eieio-default-superclass)
561 nil
562 '(eieio-default-superclass))))
563
564(defun eieio--mt--sym-optimize (class s)
565 "Find the next class above S which has a function body for the optimizer."
566 ;; Set the value to nil in case there is no nearest cell.
567 (setcdr s nil)
568 ;; Find the nearest cell that has a function body. If we find one,
569 ;; we replace the nil from above.
570 (catch 'done
571 (dolist (ancestor
572 (cl-rest (eieio--class-precedence-list class)))
573 (let ((ov (gethash ancestor eieio--mt--optimizing-hashtable)))
574 (when (car ov)
575 (setcdr s ancestor) ;; store ov as our next symbol
576 (throw 'done ancestor))))))
577
578(defun eieio--generic-form (method key class)
579 "Return the lambda form belonging to METHOD using KEY based upon CLASS.
580If CLASS is not a class then use `generic' instead. If class has
581no form, but has a parent class, then trace to that parent class.
582The first time a form is requested from a symbol, an optimized path
583is memorized for faster future use."
584 (if (symbolp class) (setq class (eieio--class-v class)))
585 (let ((emto (aref (get method 'eieio-method-hashtable)
586 (if class key (eieio--specialized-key-to-generic-key key)))))
587 (if (eieio--class-p class)
588 ;; 1) find our symbol
589 (let ((cs (gethash class emto)))
590 (unless cs
591 ;; 2) If there isn't one, then make one.
592 ;; This can be slow since it only occurs once
593 (puthash class (setq cs (list nil)) emto)
594 ;; 2.1) Cache its nearest neighbor with a quick optimize
595 ;; which should only occur once for this call ever
596 (let ((eieio--mt--optimizing-hashtable emto))
597 (eieio--mt--sym-optimize class cs)))
598 ;; 3) If it's bound return this one.
599 (if (car cs)
600 (cons (car cs) class)
601 ;; 4) If it's not bound then this variable knows something
602 (if (cdr cs)
603 (progn
604 ;; 4.1) This symbol holds the next class in its value
605 (setq class (cdr cs)
606 cs (gethash class emto))
607 ;; 4.2) The optimizer should always have chosen a
608 ;; function-symbol
609 ;;(if (car cs)
610 (cons (car cs) class)
611 ;;(error "EIEIO optimizer: erratic data loss!"))
612 )
613 ;; There never will be a funcall...
614 nil)))
615 ;; for a generic call, what is a list, is the function body we want.
616 (let ((emtl (aref (get method 'eieio-method-tree)
617 (if class key (eieio--specialized-key-to-generic-key key)))))
618 (if emtl
619 ;; The car of EMTL is supposed to be a class, which in this
620 ;; case is nil, so skip it.
621 (cons (cdr (car emtl)) nil)
622 nil)))))
623
624
625(define-error 'no-method-definition "No method definition")
626(define-error 'no-next-method "No next method")
627
628;;; CLOS methods and generics
629;;
630(defmacro defgeneric (method _args &optional doc-string)
631 "Create a generic function METHOD.
632DOC-STRING is the base documentation for this class. A generic
633function has no body, as its purpose is to decide which method body
634is appropriate to use. Uses `defmethod' to create methods, and calls
635`defgeneric' for you. With this implementation the ARGS are
636currently ignored. You can use `defgeneric' to apply specialized
637top level documentation to a method."
638 (declare (doc-string 3))
639 `(eieio--defalias ',method
640 (eieio--defgeneric-init-form ',method ,doc-string)))
641
642(defmacro defmethod (method &rest args)
643 "Create a new METHOD through `defgeneric' with ARGS.
644
645The optional second argument KEY is a specifier that
646modifies how the method is called, including:
647 :before - Method will be called before the :primary
648 :primary - The default if not specified
649 :after - Method will be called after the :primary
650 :static - First arg could be an object or class
651The next argument is the ARGLIST. The ARGLIST specifies the arguments
652to the method as with `defun'. The first argument can have a type
653specifier, such as:
654 ((VARNAME CLASS) ARG2 ...)
655where VARNAME is the name of the local variable for the method being
656created. The CLASS is a class symbol for a class made with `defclass'.
657A DOCSTRING comes after the ARGLIST, and is optional.
658All the rest of the args are the BODY of the method. A method will
659return the value of the last form in the BODY.
660
661Summary:
662
663 (defmethod mymethod [:before | :primary | :after | :static]
664 ((typearg class-name) arg2 &optional opt &rest rest)
665 \"doc-string\"
666 body)"
667 (declare (doc-string 3)
668 (debug
669 (&define ; this means we are defining something
670 [&or name ("setf" :name setf name)]
671 ;; ^^ This is the methods symbol
672 [ &optional symbolp ] ; this is key :before etc
673 list ; arguments
674 [ &optional stringp ] ; documentation string
675 def-body ; part to be debugged
676 )))
677 (let* ((key (if (keywordp (car args)) (pop args)))
678 (params (car args))
679 (arg1 (car params))
680 (fargs (if (consp arg1)
681 (cons (car arg1) (cdr params))
682 params))
683 (class (if (consp arg1) (nth 1 arg1)))
684 (code `(lambda ,fargs ,@(cdr args))))
685 `(progn
686 ;; Make sure there is a generic and the byte-compiler sees it.
687 (defgeneric ,method ,args
688 ,(or (documentation code)
689 (format "Generically created method `%s'." method)))
690 (eieio--defmethod ',method ',key ',class #',code))))
691
692
693
694;;;
695;; Method Calling Functions
696
697(defun next-method-p ()
698 "Return non-nil if there is a next method.
699Returns a list of lambda expressions which is the `next-method'
700order."
701 eieio--generic-call-next-method-list)
702
703(defun call-next-method (&rest replacement-args)
704 "Call the superclass method from a subclass method.
705The superclass method is specified in the current method list,
706and is called the next method.
707
708If REPLACEMENT-ARGS is non-nil, then use them instead of
709`eieio--generic-call-arglst'. The generic arg list are the
710arguments passed in at the top level.
711
712Use `next-method-p' to find out if there is a next method to call."
713 (if (not (eieio--scoped-class))
714 (error "`call-next-method' not called within a class specific method"))
715 (if (and (/= eieio--generic-call-key eieio--method-primary)
716 (/= eieio--generic-call-key eieio--method-static))
717 (error "Cannot `call-next-method' except in :primary or :static methods")
718 )
719 (let ((newargs (or replacement-args eieio--generic-call-arglst))
720 (next (car eieio--generic-call-next-method-list))
721 )
722 (if (not (and next (car next)))
723 (apply #'no-next-method newargs)
724 (let* ((eieio--generic-call-next-method-list
725 (cdr eieio--generic-call-next-method-list))
726 (eieio--generic-call-arglst newargs)
727 (fcn (car next))
728 )
729 (eieio--with-scoped-class (cdr next)
730 (apply fcn newargs)) ))))
731
732(defgeneric no-applicable-method (object method &rest args)
733 "Called if there are no implementations for OBJECT in METHOD.")
734
735(defmethod no-applicable-method (object method &rest _args)
736 "Called if there are no implementations for OBJECT in METHOD.
737OBJECT is the object which has no method implementation.
738ARGS are the arguments that were passed to METHOD.
739
740Implement this for a class to block this signal. The return
741value becomes the return value of the original method call."
742 (signal 'no-method-definition (list method object)))
743
744(defgeneric no-next-method (object &rest args)
745"Called from `call-next-method' when no additional methods are available.")
746
747(defmethod no-next-method (object &rest args)
748 "Called from `call-next-method' when no additional methods are available.
749OBJECT is othe object being called on `call-next-method'.
750ARGS are the arguments it is called by.
751This method signals `no-next-method' by default. Override this
752method to not throw an error, and its return value becomes the
753return value of `call-next-method'."
754 (signal 'no-next-method (list object args)))
755
756(add-hook 'help-fns-describe-function-functions 'eieio--help-generic)
757(defun eieio--help-generic (generic)
758 "Describe GENERIC if it is a generic function."
759 (when (and (symbolp generic) (generic-p generic))
760 (save-excursion
761 (goto-char (point-min))
762 (when (re-search-forward " in `.+'.$" nil t)
763 (replace-match ".")))
764 (save-excursion
765 (insert "\n\nThis is a generic function"
766 (cond
767 ((and (eieio--generic-primary-only-p generic)
768 (eieio--generic-primary-only-one-p generic))
769 " with only one primary method")
770 ((eieio--generic-primary-only-p generic)
771 " with only primary methods")
772 (t ""))
773 ".\n\n")
774 (insert (propertize "Implementations:\n\n" 'face 'bold))
775 (let ((i 4)
776 (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
777 ;; Loop over fanciful generics
778 (while (< i 7)
779 (let ((gm (aref (get generic 'eieio-method-tree) i)))
780 (when gm
781 (insert "Generic "
782 (aref prefix (- i 3))
783 "\n"
784 (or (nth 2 gm) "Undocumented")
785 "\n\n")))
786 (setq i (1+ i)))
787 (setq i 0)
788 ;; Loop over defined class-specific methods
789 (while (< i 4)
790 (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
791 cname location)
792 (while gm
793 (setq cname (caar gm))
794 (insert "`")
795 (help-insert-xref-button (symbol-name cname)
796 'help-variable cname)
797 (insert "' " (aref prefix i) " ")
798 ;; argument list
799 (let* ((func (cdr (car gm)))
800 (arglst (help-function-arglist func)))
801 (prin1 arglst (current-buffer)))
802 (insert "\n"
803 (or (documentation (cdr (car gm)))
804 "Undocumented"))
805 ;; Print file location if available
806 (when (and (setq location (get generic 'method-locations))
807 (setq location (assoc cname location)))
808 (setq location (cadr location))
809 (insert "\n\nDefined in `")
810 (help-insert-xref-button
811 (file-name-nondirectory location)
812 'eieio-method-def cname generic location)
813 (insert "'\n"))
814 (setq gm (cdr gm))
815 (insert "\n")))
816 (setq i (1+ i)))))))
817
818;;; Obsolete backward compatibility functions.
819;; Needed to run byte-code compiled with the EIEIO of Emacs-23.
820
821(defun eieio-defmethod (method args)
822 "Obsolete work part of an old version of the `defmethod' macro."
823 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
824 ;; find optional keys
825 (setq key
826 (cond ((memq (car args) '(:BEFORE :before))
827 (setq args (cdr args))
828 eieio--method-before)
829 ((memq (car args) '(:AFTER :after))
830 (setq args (cdr args))
831 eieio--method-after)
832 ((memq (car args) '(:STATIC :static))
833 (setq args (cdr args))
834 eieio--method-static)
835 ((memq (car args) '(:PRIMARY :primary))
836 (setq args (cdr args))
837 eieio--method-primary)
838 ;; Primary key.
839 (t eieio--method-primary)))
840 ;; Get body, and fix contents of args to be the arguments of the fn.
841 (setq body (cdr args)
842 args (car args))
843 (setq loopa args)
844 ;; Create a fixed version of the arguments.
845 (while loopa
846 (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
847 argfix))
848 (setq loopa (cdr loopa)))
849 ;; Make sure there is a generic.
850 (eieio-defgeneric
851 method
852 (if (stringp (car body))
853 (car body) (format "Generically created method `%s'." method)))
854 ;; create symbol for property to bind to. If the first arg is of
855 ;; the form (varname vartype) and `vartype' is a class, then
856 ;; that class will be the type symbol. If not, then it will fall
857 ;; under the type `primary' which is a non-specific calling of the
858 ;; function.
859 (setq firstarg (car args))
860 (if (listp firstarg)
861 (progn
862 (setq argclass (nth 1 firstarg))
863 (if (not (class-p argclass))
864 (error "Unknown class type %s in method parameters"
865 (nth 1 firstarg))))
866 ;; Generics are higher.
867 (setq key (eieio--specialized-key-to-generic-key key)))
868 ;; Put this lambda into the symbol so we can find it.
869 (if (byte-code-function-p (car-safe body))
870 (eieio--mt-add method (car-safe body) key argclass)
871 (eieio--mt-add method (append (list 'lambda (reverse argfix)) body)
872 key argclass))
873 )
874
875 (eieio--method-optimize-primary method)
876
877 method)
878(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1")
879
880(defun eieio-defgeneric (method doc-string)
881 "Obsolete work part of an old version of the `defgeneric' macro."
882 (if (and (fboundp method) (not (generic-p method))
883 (or (byte-code-function-p (symbol-function method))
884 (not (eq 'autoload (car (symbol-function method)))))
885 )
886 (error "You cannot create a generic/method over an existing symbol: %s"
887 method))
888 ;; Don't do this over and over.
889 (unless (fboundp 'method)
890 ;; This defun tells emacs where the first definition of this
891 ;; method is defined.
892 `(defun ,method nil)
893 ;; Make sure the method tables are installed.
894 (eieio--mt-install method)
895 ;; Apply the actual body of this function.
896 (put method 'function-documentation doc-string)
897 (fset method (eieio--defgeneric-form method))
898 ;; Return the method
899 'method))
900(make-obsolete 'eieio-defgeneric nil "24.1")
901
902(provide 'eieio-generic)
903
904;;; eieio-generic.el ends here
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index bef7ceb259a..13ad120a9b5 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -60,7 +60,7 @@ Argument 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 (eieio--check-type 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 (eieio--class-children (class-v this-root))) 63 (chl (eieio--class-children (eieio--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 " ")))
@@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object.
81 ;; Header line 81 ;; Header line
82 (prin1 class) 82 (prin1 class)
83 (insert " is a" 83 (insert " is a"
84 (if (class-option class :abstract) 84 (if (eieio--class-option (eieio--class-v class) :abstract)
85 "n abstract" 85 "n abstract"
86 "") 86 "")
87 " class") 87 " class")
@@ -149,7 +149,7 @@ If CLASS is actually an object, then also display current values of that object.
149(defun eieio-help-class-slots (class) 149(defun eieio-help-class-slots (class)
150 "Print help description for the slots in CLASS. 150 "Print help description for the slots in CLASS.
151Outputs to the current buffer." 151Outputs to the current buffer."
152 (let* ((cv (class-v class)) 152 (let* ((cv (eieio--class-v class))
153 (docs (eieio--class-public-doc cv)) 153 (docs (eieio--class-public-doc cv))
154 (names (eieio--class-public-a cv)) 154 (names (eieio--class-public-a cv))
155 (deflt (eieio--class-public-d cv)) 155 (deflt (eieio--class-public-d cv))
@@ -218,11 +218,10 @@ Outputs to the current buffer."
218(defun eieio-build-class-list (class) 218(defun eieio-build-class-list (class)
219 "Return a list of all classes that inherit from CLASS." 219 "Return a list of all classes that inherit from CLASS."
220 (if (class-p class) 220 (if (class-p class)
221 (apply #'append 221 (cl-mapcan
222 (mapcar 222 (lambda (c)
223 (lambda (c) 223 (append (list c) (eieio-build-class-list c)))
224 (append (list c) (eieio-build-class-list c))) 224 (eieio--class-children (eieio--class-v class)))
225 (eieio-class-children-fast class)))
226 (list class))) 225 (list class)))
227 226
228(defun eieio-build-class-alist (&optional class instantiable-only buildlist) 227(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
@@ -231,15 +230,16 @@ Optional argument CLASS is the class to start with.
231If INSTANTIABLE-ONLY is non nil, only allow names of classes which 230If INSTANTIABLE-ONLY is non nil, only allow names of classes which
232are not abstract, otherwise allow all classes. 231are not abstract, otherwise allow all classes.
233Optional argument BUILDLIST is more list to attach and is used internally." 232Optional argument BUILDLIST is more list to attach and is used internally."
234 (let* ((cc (or class eieio-default-superclass)) 233 (let* ((cc (or class 'eieio-default-superclass))
235 (sublst (eieio--class-children (class-v cc)))) 234 (sublst (eieio--class-children (eieio--class-v cc))))
236 (unless (assoc (symbol-name cc) buildlist) 235 (unless (assoc (symbol-name cc) buildlist)
237 (when (or (not instantiable-only) (not (class-abstract-p cc))) 236 (when (or (not instantiable-only) (not (class-abstract-p cc)))
237 ;; FIXME: Completion tables don't need alists, and ede/generic.el needs
238 ;; the symbols rather than their names.
238 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) 239 (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
239 (while sublst 240 (dolist (elem sublst)
240 (setq buildlist (eieio-build-class-alist 241 (setq buildlist (eieio-build-class-alist
241 (car sublst) instantiable-only buildlist)) 242 elem instantiable-only buildlist)))
242 (setq sublst (cdr sublst)))
243 buildlist)) 243 buildlist))
244 244
245(defvar eieio-read-class nil 245(defvar eieio-read-class nil
@@ -311,132 +311,59 @@ are not abstract."
311 (eieio-help-class ctr)) 311 (eieio-help-class ctr))
312 )))) 312 ))))
313 313
314
315;;;###autoload
316(defun eieio-help-generic (generic)
317 "Describe GENERIC if it is a generic function."
318 (when (and (symbolp generic) (generic-p generic))
319 (save-excursion
320 (goto-char (point-min))
321 (when (re-search-forward " in `.+'.$" nil t)
322 (replace-match ".")))
323 (save-excursion
324 (insert "\n\nThis is a generic function"
325 (cond
326 ((and (generic-primary-only-p generic)
327 (generic-primary-only-one-p generic))
328 " with only one primary method")
329 ((generic-primary-only-p generic)
330 " with only primary methods")
331 (t ""))
332 ".\n\n")
333 (insert (propertize "Implementations:\n\n" 'face 'bold))
334 (let ((i 4)
335 (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
336 ;; Loop over fanciful generics
337 (while (< i 7)
338 (let ((gm (aref (get generic 'eieio-method-tree) i)))
339 (when gm
340 (insert "Generic "
341 (aref prefix (- i 3))
342 "\n"
343 (or (nth 2 gm) "Undocumented")
344 "\n\n")))
345 (setq i (1+ i)))
346 (setq i 0)
347 ;; Loop over defined class-specific methods
348 (while (< i 4)
349 (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
350 cname location)
351 (while gm
352 (setq cname (caar gm))
353 (insert "`")
354 (help-insert-xref-button (symbol-name cname)
355 'help-variable cname)
356 (insert "' " (aref prefix i) " ")
357 ;; argument list
358 (let* ((func (cdr (car gm)))
359 (arglst (help-function-arglist func)))
360 (prin1 arglst (current-buffer)))
361 (insert "\n"
362 (or (documentation (cdr (car gm)))
363 "Undocumented"))
364 ;; Print file location if available
365 (when (and (setq location (get generic 'method-locations))
366 (setq location (assoc cname location)))
367 (setq location (cadr location))
368 (insert "\n\nDefined in `")
369 (help-insert-xref-button
370 (file-name-nondirectory location)
371 'eieio-method-def cname generic location)
372 (insert "'\n"))
373 (setq gm (cdr gm))
374 (insert "\n")))
375 (setq i (1+ i)))))))
376
377(defun eieio-all-generic-functions (&optional class) 314(defun eieio-all-generic-functions (&optional class)
378 "Return a list of all generic functions. 315 "Return a list of all generic functions.
379Optional CLASS argument returns only those functions that contain 316Optional CLASS argument returns only those functions that contain
380methods for CLASS." 317methods for CLASS."
381 (let ((l nil) tree (cn (if class (symbol-name class) nil))) 318 (let ((l nil))
382 (mapatoms 319 (mapatoms
383 (lambda (symbol) 320 (lambda (symbol)
384 (setq tree (get symbol 'eieio-method-obarray)) 321 (let ((tree (get symbol 'eieio-method-hashtable)))
385 (if tree 322 (when tree
386 (progn 323 ;; A symbol might be interned for that class in one of
387 ;; A symbol might be interned for that class in one of 324 ;; these three slots in the method-obarray.
388 ;; these three slots in the method-obarray. 325 (if (or (not class)
389 (if (or (not class) 326 (car (gethash class (aref tree 0)))
390 (fboundp (intern-soft cn (aref tree 0))) 327 (car (gethash class (aref tree 1)))
391 (fboundp (intern-soft cn (aref tree 1))) 328 (car (gethash class (aref tree 2))))
392 (fboundp (intern-soft cn (aref tree 2)))) 329 (setq l (cons symbol l)))))))
393 (setq l (cons symbol l)))))))
394 l)) 330 l))
395 331
396(defun eieio-method-documentation (generic class) 332(defun eieio-method-documentation (generic class)
397 "Return a list of the specific documentation of GENERIC for CLASS. 333 "Return a list of the specific documentation of GENERIC for CLASS.
398If there is not an explicit method for CLASS in GENERIC, or if that 334If there is not an explicit method for CLASS in GENERIC, or if that
399function has no documentation, then return nil." 335function has no documentation, then return nil."
400 (let ((tree (get generic 'eieio-method-obarray)) 336 (let ((tree (get generic 'eieio-method-hashtable)))
401 (cn (symbol-name class)) 337 (when tree
402 before primary after)
403 (if (not tree)
404 nil
405 ;; A symbol might be interned for that class in one of 338 ;; A symbol might be interned for that class in one of
406 ;; these three slots in the method-obarray. 339 ;; these three slots in the method-hashtable.
407 (setq before (intern-soft cn (aref tree 0)) 340 ;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static,
408 primary (intern-soft cn (aref tree 1)) 341 ;; 1 for before, and 2 for primary (and 3 for after)?
409 after (intern-soft cn (aref tree 2))) 342 (let ((before (car (gethash class (aref tree 0))))
410 (if (not (or (fboundp before) 343 (primary (car (gethash class (aref tree 1))))
411 (fboundp primary) 344 (after (car (gethash class (aref tree 2)))))
412 (fboundp after))) 345 (if (not (or before primary after))
413 nil 346 nil
414 (list (if (fboundp before) 347 (list (if before
415 (cons (help-function-arglist before) 348 (cons (help-function-arglist before)
416 (documentation before)) 349 (documentation before))
417 nil) 350 nil)
418 (if (fboundp primary) 351 (if primary
419 (cons (help-function-arglist primary) 352 (cons (help-function-arglist primary)
420 (documentation primary)) 353 (documentation primary))
421 nil) 354 nil)
422 (if (fboundp after) 355 (if after
423 (cons (help-function-arglist after) 356 (cons (help-function-arglist after)
424 (documentation after)) 357 (documentation after))
425 nil)))))) 358 nil)))))))
426 359
427(defvar eieio-read-generic nil 360(defvar eieio-read-generic nil
428 "History of the `eieio-read-generic' prompt.") 361 "History of the `eieio-read-generic' prompt.")
429 362
430(defun eieio-read-generic-p (fn)
431 "Function used in function `eieio-read-generic'.
432This is because `generic-p' is a macro.
433Argument FN is the function to test."
434 (generic-p fn))
435
436(defun eieio-read-generic (prompt &optional historyvar) 363(defun eieio-read-generic (prompt &optional historyvar)
437 "Read a generic function from the minibuffer with PROMPT. 364 "Read a generic function from the minibuffer with PROMPT.
438Optional argument HISTORYVAR is the variable to use as history." 365Optional argument HISTORYVAR is the variable to use as history."
439 (intern (completing-read prompt obarray 'eieio-read-generic-p 366 (intern (completing-read prompt obarray #'generic-p
440 t nil (or historyvar 'eieio-read-generic)))) 367 t nil (or historyvar 'eieio-read-generic))))
441 368
442;;; METHOD STATS 369;;; METHOD STATS
@@ -627,21 +554,21 @@ Optional argument HISTORYVAR is the variable to use as history."
627 () 554 ()
628 "Menu part in easymenu format used in speedbar while in `eieio' mode.") 555 "Menu part in easymenu format used in speedbar while in `eieio' mode.")
629 556
630(defun eieio-class-speedbar (dir-or-object depth) 557(defun eieio-class-speedbar (_dir-or-object _depth)
631 "Create buttons in speedbar that represents the current project. 558 "Create buttons in speedbar that represents the current project.
632DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the 559DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
633current expansion depth." 560current expansion depth."
634 (when (eq (point-min) (point-max)) 561 (when (eq (point-min) (point-max))
635 ;; This function is only called once, to start the whole deal. 562 ;; This function is only called once, to start the whole deal.
636 ;; Create and expand the default object. 563 ;; Create and expand the default object.
637 (eieio-class-button eieio-default-superclass 0) 564 (eieio-class-button 'eieio-default-superclass 0)
638 (forward-line -1) 565 (forward-line -1)
639 (speedbar-expand-line))) 566 (speedbar-expand-line)))
640 567
641(defun eieio-class-button (class depth) 568(defun eieio-class-button (class depth)
642 "Draw a speedbar button at the current point for CLASS at DEPTH." 569 "Draw a speedbar button at the current point for CLASS at DEPTH."
643 (eieio--check-type class-p class) 570 (eieio--check-type class-p class)
644 (let ((subclasses (eieio--class-children (class-v class)))) 571 (let ((subclasses (eieio--class-children (eieio--class-v class))))
645 (if subclasses 572 (if subclasses
646 (speedbar-make-tag-line 'angle ?+ 573 (speedbar-make-tag-line 'angle ?+
647 'eieio-sb-expand 574 'eieio-sb-expand
@@ -666,7 +593,7 @@ Argument INDENT is the depth of indentation."
666 (speedbar-with-writable 593 (speedbar-with-writable
667 (save-excursion 594 (save-excursion
668 (end-of-line) (forward-char 1) 595 (end-of-line) (forward-char 1)
669 (let ((subclasses (eieio--class-children (class-v class)))) 596 (let ((subclasses (eieio--class-children (eieio--class-v class))))
670 (while subclasses 597 (while subclasses
671 (eieio-class-button (car subclasses) (1+ indent)) 598 (eieio-class-button (car subclasses) (1+ indent))
672 (setq subclasses (cdr subclasses))))))) 599 (setq subclasses (cdr subclasses)))))))
@@ -676,7 +603,7 @@ Argument INDENT is the depth of indentation."
676 (t (error "Ooops... not sure what to do"))) 603 (t (error "Ooops... not sure what to do")))
677 (speedbar-center-buffer-smartly)) 604 (speedbar-center-buffer-smartly))
678 605
679(defun eieio-describe-class-sb (text token indent) 606(defun eieio-describe-class-sb (_text token _indent)
680 "Describe the class TEXT in TOKEN. 607 "Describe the class TEXT in TOKEN.
681INDENT is the current indentation level." 608INDENT is the current indentation level."
682 (dframe-with-attached-buffer 609 (dframe-with-attached-buffer
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index cf676256d43..b236f0f03e1 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -1,4 +1,4 @@
1;;; eieio-speedbar.el -- Classes for managing speedbar displays. 1;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation, 3;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation,
4;; Inc. 4;; Inc.
@@ -200,7 +200,7 @@ that path."
200 "Return a string describing OBJECT." 200 "Return a string describing OBJECT."
201 (eieio-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."
205 nil) 205 nil)
206 206
@@ -321,7 +321,7 @@ Argument DEPTH is the depth at which the tag line is inserted."
321 (if exp 321 (if exp
322 (eieio-speedbar-expand object (1+ depth)))))) 322 (eieio-speedbar-expand object (1+ depth))))))
323 323
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 (eieio-object-name object))) 327 (eieio-object-name object)))
@@ -340,7 +340,7 @@ OBJECT."
340 340
341;;; Speedbar specific function callbacks. 341;;; Speedbar specific function callbacks.
342;; 342;;
343(defun eieio-speedbar-object-click (text token indent) 343(defun eieio-speedbar-object-click (_text token _indent)
344 "Handle a user click on TEXT representing object TOKEN. 344 "Handle a user click on TEXT representing object TOKEN.
345The object is at indentation level INDENT." 345The object is at indentation level INDENT."
346 (eieio-speedbar-handle-click token)) 346 (eieio-speedbar-handle-click token))
@@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at."
412 412
413;;; Methods to the eieio-speedbar-* classes which need to be overridden. 413;;; Methods to the eieio-speedbar-* classes which need to be overridden.
414;; 414;;
415(defmethod eieio-speedbar-object-children ((object eieio-speedbar)) 415(defmethod eieio-speedbar-object-children ((_object eieio-speedbar))
416 "Return a list of children to be displayed in speedbar. 416 "Return a list of children to be displayed in speedbar.
417If the return value is a list of OBJECTs, then those objects are 417If the return value is a list of OBJECTs, then those objects are
418queried for details. If the return list is made of strings, 418queried for details. If the return list is made of strings,
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 361005414de..419a78be469 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -53,17 +53,16 @@
53 (message eieio-version)) 53 (message eieio-version))
54 54
55(require 'eieio-core) 55(require 'eieio-core)
56(require 'eieio-generic)
56 57
57 58
58;;; Defining a new class 59;;; Defining a new class
59;; 60;;
60(defmacro defclass (name superclass slots &rest options-and-doc) 61(defmacro defclass (name superclasses slots &rest options-and-doc)
61 "Define NAME as a new class derived from SUPERCLASS with SLOTS. 62 "Define NAME as a new class derived from SUPERCLASS with SLOTS.
62OPTIONS-AND-DOC is used as the class' options and base documentation. 63OPTIONS-AND-DOC is used as the class' options and base documentation.
63SUPERCLASS is a list of superclasses to inherit from, with SLOTS 64SUPERCLASSES is a list of superclasses to inherit from, with SLOTS
64being the slots residing in that class definition. NOTE: Currently 65being the slots residing in that class definition. Supported tags are:
65only one slot may exist in SUPERCLASS as multiple inheritance is not
66yet supported. Supported tags are:
67 66
68 :initform - Initializing form. 67 :initform - Initializing form.
69 :initarg - Tag used during initialization. 68 :initarg - Tag used during initialization.
@@ -114,12 +113,178 @@ Options in CLOS not supported in EIEIO:
114Due to the way class options are set up, you can add any tags you wish, 113Due to the way class options are set up, you can add any tags you wish,
115and reference them using the function `class-option'." 114and reference them using the function `class-option'."
116 (declare (doc-string 4)) 115 (declare (doc-string 4))
117 ;; This is eval-and-compile only to silence spurious compiler warnings 116 (eieio--check-type listp superclasses)
118 ;; about functions and variables not known to be defined. 117
119 ;; When eieio-defclass code is merged here and this becomes 118 (cond ((and (stringp (car options-and-doc))
120 ;; transparent to the compiler, the eval-and-compile can be removed. 119 (/= 1 (% (length options-and-doc) 2)))
121 `(eval-and-compile 120 (error "Too many arguments to `defclass'"))
122 (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) 121 ((and (symbolp (car options-and-doc))
122 (/= 0 (% (length options-and-doc) 2)))
123 (error "Too many arguments to `defclass'")))
124
125 (if (stringp (car options-and-doc))
126 (setq options-and-doc
127 (cons :documentation options-and-doc)))
128
129 ;; Make sure the method invocation order is a valid value.
130 (let ((io (eieio--class-option-assoc options-and-doc
131 :method-invocation-order)))
132 (when (and io (not (member io '(:depth-first :breadth-first :c3))))
133 (error "Method invocation order %s is not allowed" io)))
134
135 (let ((testsym1 (intern (concat (symbol-name name) "-p")))
136 (testsym2 (intern (format "eieio--childp--%s" name)))
137 (accessors ()))
138
139 ;; Collect the accessors we need to define.
140 (pcase-dolist (`(,sname . ,soptions) slots)
141 (let* ((acces (plist-get soptions :accessor))
142 (initarg (plist-get soptions :initarg))
143 (reader (plist-get soptions :reader))
144 (writer (plist-get soptions :writer))
145 (alloc (plist-get soptions :allocation))
146 (label (plist-get soptions :label)))
147
148 (if eieio-error-unsupported-class-tags
149 (let ((tmp soptions))
150 (while tmp
151 (if (not (member (car tmp) '(:accessor
152 :initform
153 :initarg
154 :documentation
155 :protection
156 :reader
157 :writer
158 :allocation
159 :type
160 :custom
161 :label
162 :group
163 :printer
164 :allow-nil-initform
165 :custom-groups)))
166 (signal 'invalid-slot-type (list (car tmp))))
167 (setq tmp (cdr (cdr tmp))))))
168
169 ;; Make sure the :allocation parameter has a valid value.
170 (if (not (memq alloc '(nil :class :instance)))
171 (signal 'invalid-slot-type (list :allocation alloc)))
172
173 ;; Label is nil, or a string
174 (if (not (or (null label) (stringp label)))
175 (signal 'invalid-slot-type (list :label label)))
176
177 ;; Is there an initarg, but allocation of class?
178 (if (and initarg (eq alloc :class))
179 (message "Class allocated slots do not need :initarg"))
180
181 ;; Anyone can have an accessor function. This creates a function
182 ;; of the specified name, and also performs a `defsetf' if applicable
183 ;; so that users can `setf' the space returned by this function.
184 (when acces
185 ;; FIXME: The defmethod below only defines a part of the generic
186 ;; function (good), but the define-setter below affects the whole
187 ;; generic function (bad)!
188 (push `(gv-define-setter ,acces (store object)
189 ;; Apparently, eieio-oset-default doesn't work like
190 ;; oref-default and only accept class arguments!
191 (list ',(if nil ;; (eq alloc :class)
192 'eieio-oset-default
193 'eieio-oset)
194 object '',sname store))
195 accessors)
196 (push `(defmethod ,acces ,(if (eq alloc :class) :static :primary)
197 ((this ,name))
198 ,(format
199 "Retrieve the slot `%S' from an object of class `%S'."
200 sname name)
201 (if (slot-boundp this ',sname)
202 ;; Use oref-default for :class allocated slots, since
203 ;; these also accept the use of a class argument instead
204 ;; of an object argument.
205 (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
206 this ',sname)
207 ;; Else - Some error? nil?
208 nil))
209 accessors))
210
211 ;; If a writer is defined, then create a generic method of that
212 ;; name whose purpose is to set the value of the slot.
213 (if writer
214 (push `(defmethod ,writer ((this ,name) value)
215 ,(format "Set the slot `%S' of an object of class `%S'."
216 sname name)
217 (setf (slot-value this ',sname) value))
218 accessors))
219 ;; If a reader is defined, then create a generic method
220 ;; of that name whose purpose is to access this slot value.
221 (if reader
222 (push `(defmethod ,reader ((this ,name))
223 ,(format "Access the slot `%S' from object of class `%S'."
224 sname name)
225 (slot-value this ',sname))
226 accessors))
227 ))
228
229 `(progn
230 ;; This test must be created right away so we can have self-
231 ;; referencing classes. ei, a class whose slot can contain only
232 ;; pointers to itself.
233
234 ;; Create the test function.
235 (defun ,testsym1 (obj)
236 ,(format "Test OBJ to see if it an object of type %S." name)
237 (and (eieio-object-p obj)
238 (same-class-p obj ',name)))
239
240 (defun ,testsym2 (obj)
241 ,(format
242 "Test OBJ to see if it an object is a child of type %S."
243 name)
244 (and (eieio-object-p obj)
245 (object-of-class-p obj ',name)))
246
247 ,@(when eieio-backward-compatibility
248 (let ((f (intern (format "%s-child-p" name))))
249 `((defalias ',f ',testsym2)
250 (make-obsolete
251 ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1"))))
252
253 ;; When using typep, (typep OBJ 'myclass) returns t for objects which
254 ;; are subclasses of myclass. For our predicates, however, it is
255 ;; important for EIEIO to be backwards compatible, where
256 ;; myobject-p, and myobject-child-p are different.
257 ;; "cl" uses this technique to specify symbols with specific typep
258 ;; test, so we can let typep have the CLOS documented behavior
259 ;; while keeping our above predicate clean.
260
261 (put ',name 'cl-deftype-satisfies #',testsym2)
262
263 (eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc)
264
265 ,@accessors
266
267 ;; Create the constructor function
268 ,(if (eieio--class-option-assoc options-and-doc :abstract)
269 ;; Abstract classes cannot be instantiated. Say so.
270 (let ((abs (eieio--class-option-assoc options-and-doc :abstract)))
271 (if (not (stringp abs))
272 (setq abs (format "Class %s is abstract" name)))
273 `(defun ,name (&rest _)
274 ,(format "You cannot create a new object of type %S." name)
275 (error ,abs)))
276
277 ;; Non-abstract classes need a constructor.
278 `(defun ,name (&rest slots)
279 ,(format "Create a new object with name NAME of class type %S."
280 name)
281 (if (and slots
282 (let ((x (car slots)))
283 (or (stringp x) (null x))))
284 (funcall (if eieio-backward-compatibility #'ignore #'message)
285 "Obsolete name %S passed to %S constructor"
286 (pop slots) ',name))
287 (apply #'eieio-constructor ',name slots))))))
123 288
124 289
125;;; CLOS style implementation of object creators. 290;;; CLOS style implementation of object creators.
@@ -144,75 +309,16 @@ In EIEIO, the class' constructor requires a name for use when printing.
144`make-instance' in CLOS doesn't use names the way Emacs does, so the 309`make-instance' in CLOS doesn't use names the way Emacs does, so the
145class is used as the name slot instead when INITARGS doesn't start with 310class is used as the name slot instead when INITARGS doesn't start with
146a string." 311a string."
147 (if (and (car initargs) (stringp (car initargs))) 312 (apply (class-constructor class) initargs))
148 (apply (class-constructor class) initargs)
149 (apply (class-constructor class)
150 (cond ((symbolp class) (symbol-name class))
151 (t (format "%S" class)))
152 initargs)))
153 313
154 314
155;;; CLOS methods and generics
156;;
157(defmacro defgeneric (method _args &optional doc-string)
158 "Create a generic function METHOD.
159DOC-STRING is the base documentation for this class. A generic
160function has no body, as its purpose is to decide which method body
161is appropriate to use. Uses `defmethod' to create methods, and calls
162`defgeneric' for you. With this implementation the ARGS are
163currently ignored. You can use `defgeneric' to apply specialized
164top level documentation to a method."
165 (declare (doc-string 3))
166 `(eieio--defalias ',method
167 (eieio--defgeneric-init-form ',method ,doc-string)))
168
169(defmacro defmethod (method &rest args)
170 "Create a new METHOD through `defgeneric' with ARGS.
171
172The optional second argument KEY is a specifier that
173modifies how the method is called, including:
174 :before - Method will be called before the :primary
175 :primary - The default if not specified
176 :after - Method will be called after the :primary
177 :static - First arg could be an object or class
178The next argument is the ARGLIST. The ARGLIST specifies the arguments
179to the method as with `defun'. The first argument can have a type
180specifier, such as:
181 ((VARNAME CLASS) ARG2 ...)
182where VARNAME is the name of the local variable for the method being
183created. The CLASS is a class symbol for a class made with `defclass'.
184A DOCSTRING comes after the ARGLIST, and is optional.
185All the rest of the args are the BODY of the method. A method will
186return the value of the last form in the BODY.
187
188Summary:
189
190 (defmethod mymethod [:before | :primary | :after | :static]
191 ((typearg class-name) arg2 &optional opt &rest rest)
192 \"doc-string\"
193 body)"
194 (declare (doc-string 3))
195 (let* ((key (if (keywordp (car args)) (pop args)))
196 (params (car args))
197 (arg1 (car params))
198 (fargs (if (consp arg1)
199 (cons (car arg1) (cdr params))
200 params))
201 (class (if (consp arg1) (nth 1 arg1)))
202 (code `(lambda ,fargs ,@(cdr args))))
203 `(progn
204 ;; Make sure there is a generic and the byte-compiler sees it.
205 (defgeneric ,method ,args
206 ,(or (documentation code)
207 (format "Generically created method `%s'." method)))
208 (eieio--defmethod ',method ',key ',class #',code))))
209
210;;; Get/Set slots in an object. 315;;; Get/Set slots in an object.
211;; 316;;
212(defmacro oref (obj slot) 317(defmacro oref (obj slot)
213 "Retrieve the value stored in OBJ in the slot named by SLOT. 318 "Retrieve the value stored in OBJ in the slot named by SLOT.
214Slot is the name of the slot when created by `defclass' or the label 319Slot is the name of the slot when created by `defclass' or the label
215created by the :initarg tag." 320created by the :initarg tag."
321 (declare (debug (form symbolp)))
216 `(eieio-oref ,obj (quote ,slot))) 322 `(eieio-oref ,obj (quote ,slot)))
217 323
218(defalias 'slot-value 'eieio-oref) 324(defalias 'slot-value 'eieio-oref)
@@ -223,6 +329,7 @@ created by the :initarg tag."
223The default value is the value installed in a class with the :initform 329The default value is the value installed in a class with the :initform
224tag. SLOT can be the slot name, or the tag specified by the :initarg 330tag. SLOT can be the slot name, or the tag specified by the :initarg
225tag in the `defclass' call." 331tag in the `defclass' call."
332 (declare (debug (form symbolp)))
226 `(eieio-oref-default ,obj (quote ,slot))) 333 `(eieio-oref-default ,obj (quote ,slot)))
227 334
228;;; Handy CLOS macros 335;;; Handy CLOS macros
@@ -246,7 +353,7 @@ SPEC-LIST is of a form similar to `let'. For example:
246Where each VAR is the local variable given to the associated 353Where each VAR is the local variable given to the associated
247SLOT. A slot specified without a variable name is given a 354SLOT. A slot specified without a variable name is given a
248variable name of the same name as the slot." 355variable name of the same name as the slot."
249 (declare (indent 2)) 356 (declare (indent 2) (debug (sexp sexp def-body)))
250 (require 'cl-lib) 357 (require 'cl-lib)
251 ;; Transform the spec-list into a cl-symbol-macrolet spec-list. 358 ;; Transform the spec-list into a cl-symbol-macrolet spec-list.
252 (let ((mappings (mapcar (lambda (entry) 359 (let ((mappings (mapcar (lambda (entry)
@@ -261,33 +368,43 @@ variable name of the same name as the slot."
261;; well embedded into an object. 368;; well embedded into an object.
262;; 369;;
263(define-obsolete-function-alias 370(define-obsolete-function-alias
264 'object-class-fast #'eieio--object-class "24.4") 371 'object-class-fast #'eieio--object-class-name "24.4")
265 372
266(defun eieio-object-name (obj &optional extra) 373(defun eieio-object-name (obj &optional extra)
267 "Return a Lisp like symbol string for object OBJ. 374 "Return a Lisp like symbol string for object OBJ.
268If EXTRA, include that in the string returned to represent the symbol." 375If EXTRA, include that in the string returned to represent the symbol."
269 (eieio--check-type eieio-object-p obj) 376 (eieio--check-type eieio-object-p obj)
270 (format "#<%s %s%s>" (symbol-name (eieio--object-class obj)) 377 (format "#<%s %s%s>" (eieio--object-class-name obj)
271 (eieio--object-name obj) (or extra ""))) 378 (eieio-object-name-string obj) (or extra "")))
272(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") 379(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4")
273 380
274(defun eieio-object-name-string (obj) "Return a string which is OBJ's name." 381(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key))
275 (eieio--check-type eieio-object-p obj) 382
276 (eieio--object-name obj)) 383;; In the past, every EIEIO object had a `name' field, so we had the two method
384;; below "for free". Since this field is very rarely used, we got rid of it
385;; and instead we keep it in a weak hash-tables, for those very rare objects
386;; that use it.
387(defmethod eieio-object-name-string (obj)
388 "Return a string which is OBJ's name."
389 (declare (obsolete eieio-named "25.1"))
390 (or (gethash obj eieio--object-names)
391 (symbol-name (eieio-object-class obj))))
277(define-obsolete-function-alias 392(define-obsolete-function-alias
278 'object-name-string #'eieio-object-name-string "24.4") 393 'object-name-string #'eieio-object-name-string "24.4")
279 394
280(defun eieio-object-set-name-string (obj name) 395(defmethod eieio-object-set-name-string (obj name)
281 "Set the string which is OBJ's NAME." 396 "Set the string which is OBJ's NAME."
282 (eieio--check-type eieio-object-p obj) 397 (declare (obsolete eieio-named "25.1"))
283 (eieio--check-type stringp name) 398 (eieio--check-type stringp name)
284 (setf (eieio--object-name obj) name)) 399 (setf (gethash obj eieio--object-names) name))
285(define-obsolete-function-alias 400(define-obsolete-function-alias
286 'object-set-name-string 'eieio-object-set-name-string "24.4") 401 'object-set-name-string 'eieio-object-set-name-string "24.4")
287 402
288(defun eieio-object-class (obj) "Return the class struct defining OBJ." 403(defun eieio-object-class (obj)
404 "Return the class struct defining OBJ."
405 ;; FIXME: We say we return a "struct" but we return a symbol instead!
289 (eieio--check-type eieio-object-p obj) 406 (eieio--check-type eieio-object-p obj)
290 (eieio--object-class obj)) 407 (eieio--object-class-name obj))
291(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") 408(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4")
292;; CLOS name, maybe? 409;; CLOS name, maybe?
293(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") 410(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4")
@@ -295,7 +412,7 @@ If EXTRA, include that in the string returned to represent the symbol."
295(defun eieio-object-class-name (obj) 412(defun eieio-object-class-name (obj)
296 "Return a Lisp like symbol name for OBJ's class." 413 "Return a Lisp like symbol name for OBJ's class."
297 (eieio--check-type eieio-object-p obj) 414 (eieio--check-type eieio-object-p obj)
298 (eieio-class-name (eieio--object-class obj))) 415 (eieio-class-name (eieio--object-class-name obj)))
299(define-obsolete-function-alias 416(define-obsolete-function-alias
300 'object-class-name 'eieio-object-class-name "24.4") 417 'object-class-name 'eieio-object-class-name "24.4")
301 418
@@ -303,15 +420,16 @@ If EXTRA, include that in the string returned to represent the symbol."
303 "Return parent classes to CLASS. (overload of variable). 420 "Return parent classes to CLASS. (overload of variable).
304 421
305The CLOS function `class-direct-superclasses' is aliased to this function." 422The CLOS function `class-direct-superclasses' is aliased to this function."
306 (eieio--check-type class-p class) 423 (let ((c (eieio-class-object class)))
307 (eieio-class-parents-fast class)) 424 (eieio--class-parent c)))
425
308(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") 426(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
309 427
310(defun eieio-class-children (class) 428(defun eieio-class-children (class)
311 "Return child classes to CLASS. 429 "Return child classes to CLASS.
312The CLOS function `class-direct-subclasses' is aliased to this function." 430The CLOS function `class-direct-subclasses' is aliased to this function."
313 (eieio--check-type class-p class) 431 (eieio--check-type class-p class)
314 (eieio-class-children-fast class)) 432 (eieio--class-children (eieio--class-v class)))
315(define-obsolete-function-alias 433(define-obsolete-function-alias
316 'class-children #'eieio-class-children "24.4") 434 'class-children #'eieio-class-children "24.4")
317 435
@@ -326,38 +444,44 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
326 `(car (eieio-class-parents ,class))) 444 `(car (eieio-class-parents ,class)))
327(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") 445(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4")
328 446
329(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." 447(defun same-class-p (obj class)
330 (eieio--check-type class-p class) 448 "Return t if OBJ is of class-type CLASS."
449 (setq class (eieio--class-object class))
450 (eieio--check-type eieio--class-p class)
331 (eieio--check-type eieio-object-p obj) 451 (eieio--check-type eieio-object-p obj)
332 (same-class-fast-p obj class)) 452 (eq (eieio--object-class-object obj) class))
333 453
334(defun object-of-class-p (obj class) 454(defun object-of-class-p (obj class)
335 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." 455 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
336 (eieio--check-type eieio-object-p obj) 456 (eieio--check-type eieio-object-p obj)
337 ;; class will be checked one layer down 457 ;; class will be checked one layer down
338 (child-of-class-p (eieio--object-class obj) class)) 458 (child-of-class-p (eieio--object-class-object obj) class))
339;; Backwards compatibility 459;; Backwards compatibility
340(defalias 'obj-of-class-p 'object-of-class-p) 460(defalias 'obj-of-class-p 'object-of-class-p)
341 461
342(defun child-of-class-p (child class) 462(defun child-of-class-p (child class)
343 "Return non-nil if CHILD class is a subclass of CLASS." 463 "Return non-nil if CHILD class is a subclass of CLASS."
344 (eieio--check-type class-p class) 464 (setq child (eieio--class-object child))
345 (eieio--check-type class-p child) 465 (eieio--check-type eieio--class-p child)
346 (let ((p nil)) 466 ;; `eieio-default-superclass' is never mentioned in eieio--class-parent,
347 (while (and child (not (eq child class))) 467 ;; so we have to special case it here.
348 (setq p (append p (eieio--class-parent (class-v child))) 468 (or (eq class 'eieio-default-superclass)
349 child (car p) 469 (let ((p nil))
350 p (cdr p))) 470 (setq class (eieio--class-object class))
351 (if child t))) 471 (eieio--check-type eieio--class-p class)
472 (while (and child (not (eq child class)))
473 (setq p (append p (eieio--class-parent child))
474 child (pop p)))
475 (if child t))))
352 476
353(defun object-slots (obj) 477(defun object-slots (obj)
354 "Return list of slots available in OBJ." 478 "Return list of slots available in OBJ."
355 (eieio--check-type eieio-object-p obj) 479 (eieio--check-type eieio-object-p obj)
356 (eieio--class-public-a (class-v (eieio--object-class obj)))) 480 (eieio--class-public-a (eieio--object-class-object obj)))
357 481
358(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." 482(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
359 (eieio--check-type class-p class) 483 (eieio--check-type eieio--class-p class)
360 (let ((ia (eieio--class-initarg-tuples (class-v class))) 484 (let ((ia (eieio--class-initarg-tuples class))
361 (f nil)) 485 (f nil))
362 (while (and ia (not f)) 486 (while (and ia (not f))
363 (if (eq (cdr (car ia)) slot) 487 (if (eq (cdr (car ia)) slot)
@@ -371,6 +495,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
371 "Set the value in OBJ for slot SLOT to VALUE. 495 "Set the value in OBJ for slot SLOT to VALUE.
372SLOT is the slot name as specified in `defclass' or the tag created 496SLOT is the slot name as specified in `defclass' or the tag created
373with in the :initarg slot. VALUE can be any Lisp object." 497with in the :initarg slot. VALUE can be any Lisp object."
498 (declare (debug (form symbolp form)))
374 `(eieio-oset ,obj (quote ,slot) ,value)) 499 `(eieio-oset ,obj (quote ,slot) ,value))
375 500
376(defmacro oset-default (class slot value) 501(defmacro oset-default (class slot value)
@@ -378,6 +503,7 @@ with in the :initarg slot. VALUE can be any Lisp object."
378The default value is usually set with the :initform tag during class 503The default value is usually set with the :initform tag during class
379creation. This allows users to change the default behavior of classes 504creation. This allows users to change the default behavior of classes
380after they are created." 505after they are created."
506 (declare (debug (form symbolp form)))
381 `(eieio-oset-default ,class (quote ,slot) ,value)) 507 `(eieio-oset-default ,class (quote ,slot) ,value))
382 508
383;;; CLOS queries into classes and slots 509;;; CLOS queries into classes and slots
@@ -402,11 +528,9 @@ OBJECT can be an instance or a class."
402 528
403(defun slot-exists-p (object-or-class slot) 529(defun slot-exists-p (object-or-class slot)
404 "Return non-nil if OBJECT-OR-CLASS has SLOT." 530 "Return non-nil if OBJECT-OR-CLASS has SLOT."
405 (let ((cv (class-v (cond ((eieio-object-p object-or-class) 531 (let ((cv (cond ((eieio-object-p object-or-class)
406 (eieio-object-class object-or-class)) 532 (eieio--object-class-object object-or-class))
407 ((class-p object-or-class) 533 (t (eieio-class-object object-or-class)))))
408 object-or-class))
409 )))
410 (or (memq slot (eieio--class-public-a cv)) 534 (or (memq slot (eieio--class-public-a cv))
411 (memq slot (eieio--class-class-allocation-a cv))) 535 (memq slot (eieio--class-class-allocation-a cv)))
412 )) 536 ))
@@ -418,7 +542,7 @@ If ERRORP is non-nil, `wrong-argument-type' is signaled."
418 (if (not (class-p symbol)) 542 (if (not (class-p symbol))
419 (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) 543 (if errorp (signal 'wrong-type-argument (list 'class-p symbol))
420 nil) 544 nil)
421 (class-v symbol))) 545 (eieio--class-v symbol)))
422 546
423;;; Slightly more complex utility functions for objects 547;;; Slightly more complex utility functions for objects
424;; 548;;
@@ -496,44 +620,6 @@ If SLOT is unbound, do nothing."
496 nil 620 nil
497 (eieio-oset object slot (delete item (eieio-oref object slot))))) 621 (eieio-oset object slot (delete item (eieio-oref object slot)))))
498 622
499;;;
500;; Method Calling Functions
501
502(defun next-method-p ()
503 "Return non-nil if there is a next method.
504Returns a list of lambda expressions which is the `next-method'
505order."
506 eieio-generic-call-next-method-list)
507
508(defun call-next-method (&rest replacement-args)
509 "Call the superclass method from a subclass method.
510The superclass method is specified in the current method list,
511and is called the next method.
512
513If REPLACEMENT-ARGS is non-nil, then use them instead of
514`eieio-generic-call-arglst'. The generic arg list are the
515arguments passed in at the top level.
516
517Use `next-method-p' to find out if there is a next method to call."
518 (if (not (eieio--scoped-class))
519 (error "`call-next-method' not called within a class specific method"))
520 (if (and (/= eieio-generic-call-key method-primary)
521 (/= eieio-generic-call-key method-static))
522 (error "Cannot `call-next-method' except in :primary or :static methods")
523 )
524 (let ((newargs (or replacement-args eieio-generic-call-arglst))
525 (next (car eieio-generic-call-next-method-list))
526 )
527 (if (or (not next) (not (car next)))
528 (apply #'no-next-method (car newargs) (cdr newargs))
529 (let* ((eieio-generic-call-next-method-list
530 (cdr eieio-generic-call-next-method-list))
531 (eieio-generic-call-arglst newargs)
532 (fcn (car next))
533 )
534 (eieio--with-scoped-class (cdr next)
535 (apply fcn newargs)) ))))
536
537;;; Here are some CLOS items that need the CL package 623;;; Here are some CLOS items that need the CL package
538;; 624;;
539 625
@@ -556,22 +642,23 @@ Its slots are automatically adopted by classes with no specified parents.
556This class is not stored in the `parent' slot of a class vector." 642This class is not stored in the `parent' slot of a class vector."
557 :abstract t) 643 :abstract t)
558 644
645(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass))
646
559(defalias 'standard-class 'eieio-default-superclass) 647(defalias 'standard-class 'eieio-default-superclass)
560 648
561(defgeneric constructor (class newname &rest slots) 649(defgeneric eieio-constructor (class &rest slots)
562 "Default constructor for CLASS `eieio-default-superclass'.") 650 "Default constructor for CLASS `eieio-default-superclass'.")
563 651
564(defmethod constructor :static 652(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1")
565 ((class eieio-default-superclass) newname &rest slots) 653
654(defmethod eieio-constructor :static
655 ((class eieio-default-superclass) &rest slots)
566 "Default constructor for CLASS `eieio-default-superclass'. 656 "Default constructor for CLASS `eieio-default-superclass'.
567NEWNAME is the name to be given to the constructed object.
568SLOTS are the initialization slots used by `shared-initialize'. 657SLOTS are the initialization slots used by `shared-initialize'.
569This static method is called when an object is constructed. 658This static method is called when an object is constructed.
570It allocates the vector used to represent an EIEIO object, and then 659It allocates the vector used to represent an EIEIO object, and then
571calls `shared-initialize' on that object." 660calls `shared-initialize' on that object."
572 (let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class))))) 661 (let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class)))))
573 ;; Update the name for the newly created object.
574 (setf (eieio--object-name new-object) newname)
575 ;; Call the initialize method on the new object with the slots 662 ;; Call the initialize method on the new object with the slots
576 ;; that were passed down to us. 663 ;; that were passed down to us.
577 (initialize-instance new-object slots) 664 (initialize-instance new-object slots)
@@ -585,10 +672,10 @@ Called from the constructor routine.")
585(defmethod shared-initialize ((obj eieio-default-superclass) slots) 672(defmethod shared-initialize ((obj eieio-default-superclass) slots)
586 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 673 "Set slots of OBJ with SLOTS which is a list of name/value pairs.
587Called from the constructor routine." 674Called from the constructor routine."
588 (eieio--with-scoped-class (eieio--object-class obj) 675 (eieio--with-scoped-class (eieio--object-class-object obj)
589 (while slots 676 (while slots
590 (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj) 677 (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
591 (car slots)))) 678 (car slots))))
592 (if (not rn) 679 (if (not rn)
593 (slot-missing obj (car slots) 'oset (car (cdr slots))) 680 (slot-missing obj (car slots) 'oset (car (cdr slots)))
594 (eieio-oset obj rn (car (cdr slots))))) 681 (eieio-oset obj rn (car (cdr slots)))))
@@ -609,7 +696,7 @@ not taken, then new objects of your class will not have their values
609dynamically set from SLOTS." 696dynamically set from SLOTS."
610 ;; First, see if any of our defaults are `lambda', and 697 ;; First, see if any of our defaults are `lambda', and
611 ;; re-evaluate them and apply the value to our slots. 698 ;; re-evaluate them and apply the value to our slots.
612 (let* ((this-class (class-v (eieio--object-class this))) 699 (let* ((this-class (eieio--object-class-object this))
613 (slot (eieio--class-public-a this-class)) 700 (slot (eieio--class-public-a this-class))
614 (defaults (eieio--class-public-d this-class))) 701 (defaults (eieio--class-public-d this-class)))
615 (while slot 702 (while slot
@@ -662,34 +749,6 @@ EIEIO can only dispatch on the first argument, so the first two are swapped."
662 (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) 749 (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object)
663 slot-name fn))) 750 slot-name fn)))
664 751
665(defgeneric no-applicable-method (object method &rest args)
666 "Called if there are no implementations for OBJECT in METHOD.")
667
668(defmethod no-applicable-method ((object eieio-default-superclass)
669 method &rest _args)
670 "Called if there are no implementations for OBJECT in METHOD.
671OBJECT is the object which has no method implementation.
672ARGS are the arguments that were passed to METHOD.
673
674Implement this for a class to block this signal. The return
675value becomes the return value of the original method call."
676 (signal 'no-method-definition (list method (eieio-object-name object)))
677 )
678
679(defgeneric no-next-method (object &rest args)
680"Called from `call-next-method' when no additional methods are available.")
681
682(defmethod no-next-method ((object eieio-default-superclass)
683 &rest args)
684 "Called from `call-next-method' when no additional methods are available.
685OBJECT is othe object being called on `call-next-method'.
686ARGS are the arguments it is called by.
687This method signals `no-next-method' by default. Override this
688method to not throw an error, and its return value becomes the
689return value of `call-next-method'."
690 (signal 'no-next-method (list (eieio-object-name object) args))
691 )
692
693(defgeneric clone (obj &rest params) 752(defgeneric clone (obj &rest params)
694 "Make a copy of OBJ, and then supply PARAMS. 753 "Make a copy of OBJ, and then supply PARAMS.
695PARAMS is a parameter list of the same form used by `initialize-instance'. 754PARAMS is a parameter list of the same form used by `initialize-instance'.
@@ -699,18 +758,11 @@ first and modify the returned object.")
699 758
700(defmethod clone ((obj eieio-default-superclass) &rest params) 759(defmethod clone ((obj eieio-default-superclass) &rest params)
701 "Make a copy of OBJ, and then apply PARAMS." 760 "Make a copy of OBJ, and then apply PARAMS."
702 (let ((nobj (copy-sequence obj)) 761 (let ((nobj (copy-sequence obj)))
703 (nm (eieio--object-name obj)) 762 (if (stringp (car params))
704 (passname (and params (stringp (car params)))) 763 (funcall (if eieio-backward-compatibility #'ignore #'message)
705 (num 1)) 764 "Obsolete name %S passed to clone" (pop params)))
706 (if params (shared-initialize nobj (if passname (cdr params) params))) 765 (if params (shared-initialize nobj params))
707 (if (not passname)
708 (save-match-data
709 (if (string-match "-\\([0-9]+\\)" nm)
710 (setq num (1+ (string-to-number (match-string 1 nm)))
711 nm (substring nm 0 (match-beginning 0))))
712 (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
713 (setf (eieio--object-name nobj) (car params)))
714 nobj)) 766 nobj))
715 767
716(defgeneric destructor (this &rest params) 768(defgeneric destructor (this &rest params)
@@ -764,7 +816,7 @@ this object."
764 (princ comment) 816 (princ comment)
765 (princ "\n")) 817 (princ "\n"))
766 (let* ((cl (eieio-object-class this)) 818 (let* ((cl (eieio-object-class this))
767 (cv (class-v cl))) 819 (cv (eieio--class-v cl)))
768 ;; Now output readable lisp to recreate this object 820 ;; Now output readable lisp to recreate this object
769 ;; It should look like this: 821 ;; It should look like this:
770 ;; (<constructor> <name> <slot> <slot> ... ) 822 ;; (<constructor> <name> <slot> <slot> ... )
@@ -782,7 +834,7 @@ this object."
782 (eieio-print-depth (1+ eieio-print-depth))) 834 (eieio-print-depth (1+ eieio-print-depth)))
783 (while publa 835 (while publa
784 (when (slot-boundp this (car publa)) 836 (when (slot-boundp this (car publa))
785 (let ((i (class-slot-initarg cl (car publa))) 837 (let ((i (eieio--class-slot-initarg cv (car publa)))
786 (v (eieio-oref this (car publa))) 838 (v (eieio-oref this (car publa)))
787 ) 839 )
788 (unless (or (not i) (equal v (car publd))) 840 (unless (or (not i) (equal v (car publd)))
@@ -848,7 +900,6 @@ of `eq'."
848 (error "EIEIO: `change-class' is unimplemented")) 900 (error "EIEIO: `change-class' is unimplemented"))
849 901
850;; Hook ourselves into help system for describing classes and methods. 902;; Hook ourselves into help system for describing classes and methods.
851(add-hook 'help-fns-describe-function-functions 'eieio-help-generic)
852(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) 903(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor)
853 904
854;;; Interfacing with edebug 905;;; Interfacing with edebug
@@ -859,43 +910,23 @@ of `eq'."
859Used as advice around `edebug-prin1-to-string', held in the 910Used as advice around `edebug-prin1-to-string', held in the
860variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to 911variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
861`prin1-to-string' when appropriate." 912`prin1-to-string' when appropriate."
862 (cond ((class-p object) (eieio-class-name object)) 913 (cond ((eieio--class-p object) (eieio-class-name object))
863 ((eieio-object-p object) (object-print object)) 914 ((eieio-object-p object) (object-print object))
864 ((and (listp object) (or (class-p (car object)) 915 ((and (listp object) (or (eieio--class-p (car object))
865 (eieio-object-p (car object)))) 916 (eieio-object-p (car object))))
866 (concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ") 917 (concat "(" (mapconcat
918 (lambda (x) (eieio-edebug-prin1-to-string print-function x))
919 object " ")
867 ")")) 920 ")"))
868 (t (funcall print-function object noescape)))) 921 (t (funcall print-function object noescape))))
869 922
870(add-hook 'edebug-setup-hook 923(advice-add 'edebug-prin1-to-string
871 (lambda () 924 :around #'eieio-edebug-prin1-to-string)
872 (def-edebug-spec defmethod
873 (&define ; this means we are defining something
874 [&or name ("setf" :name setf name)]
875 ;; ^^ This is the methods symbol
876 [ &optional symbolp ] ; this is key :before etc
877 list ; arguments
878 [ &optional stringp ] ; documentation string
879 def-body ; part to be debugged
880 ))
881 ;; The rest of the macros
882 (def-edebug-spec oref (form quote))
883 (def-edebug-spec oref-default (form quote))
884 (def-edebug-spec oset (form quote form))
885 (def-edebug-spec oset-default (form quote form))
886 (def-edebug-spec class-v form)
887 (def-edebug-spec class-p form)
888 (def-edebug-spec eieio-object-p form)
889 (def-edebug-spec class-constructor form)
890 (def-edebug-spec generic-p form)
891 (def-edebug-spec with-slots (list list def-body))
892 (advice-add 'edebug-prin1-to-string
893 :around #'eieio-edebug-prin1-to-string)))
894 925
895 926
896;;; Start of automatically extracted autoloads. 927;;; Start of automatically extracted autoloads.
897 928
898;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "62709d76ae43f4fe70ed922391f9c64d") 929;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "9a908efef1720439feb6323c1dd01770")
899;;; Generated autoloads from eieio-custom.el 930;;; Generated autoloads from eieio-custom.el
900 931
901(autoload 'customize-object "eieio-custom" "\ 932(autoload 'customize-object "eieio-custom" "\
@@ -906,7 +937,7 @@ Optional argument GROUP is the sub-group of slots to display.
906 937
907;;;*** 938;;;***
908 939
909;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "76058d02377b677eed3d15c28fc7ab21") 940;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "e922bf7ebc7dcb272480c4ba148da1ac")
910;;; Generated autoloads from eieio-opt.el 941;;; Generated autoloads from eieio-opt.el
911 942
912(autoload 'eieio-browse "eieio-opt" "\ 943(autoload 'eieio-browse "eieio-opt" "\
@@ -927,11 +958,6 @@ Describe CTR if it is a class constructor.
927 958
928\(fn CTR)" nil nil) 959\(fn CTR)" nil nil)
929 960
930(autoload 'eieio-help-generic "eieio-opt" "\
931Describe GENERIC if it is a generic function.
932
933\(fn GENERIC)" nil nil)
934
935;;;*** 961;;;***
936 962
937;;; End of automatically extracted autoloads. 963;;; End of automatically extracted autoloads.
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 93117d31c99..20de9aea136 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,7 @@
12015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * registry.el: Don't use <class> as a variable.
4
12014-12-29 Paul Eggert <eggert@cs.ucla.edu> 52014-12-29 Paul Eggert <eggert@cs.ucla.edu>
2 6
3 * message.el (message-make-fqdn): 7 * message.el (message-make-fqdn):
@@ -12,8 +16,8 @@
12 16
132014-12-19 Andreas Schwab <schwab@linux-m68k.org> 172014-12-19 Andreas Schwab <schwab@linux-m68k.org>
14 18
15 * gnus-group.el (gnus-read-ephemeral-bug-group): Bind 19 * gnus-group.el (gnus-read-ephemeral-bug-group):
16 coding-system-for-read and coding-system-for-write only around 20 Bind coding-system-for-read and coding-system-for-write only around
17 with-temp-file, and make buffer unibyte. Don't write temp file twice. 21 with-temp-file, and make buffer unibyte. Don't write temp file twice.
18 22
192014-12-18 Paul Eggert <eggert@cs.ucla.edu> 232014-12-18 Paul Eggert <eggert@cs.ucla.edu>
@@ -73,9 +77,9 @@
73 77
742014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org> 782014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
75 79
76 * gnus-art.el (gnus-article-mime-handles): Refactored out into own 80 * gnus-art.el (gnus-article-mime-handles): Refactor out into own
77 function for reuse. 81 function for reuse.
78 (gnus-mime-buttonize-attachments-in-header): Adjusted. 82 (gnus-mime-buttonize-attachments-in-header): Adjust.
79 83
802014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org> 842014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
81 85
diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el
index b3a2abfe26f..55b83a8e889 100644
--- a/lisp/gnus/registry.el
+++ b/lisp/gnus/registry.el
@@ -124,7 +124,7 @@
124 :type hash-table 124 :type hash-table
125 :documentation "The data hashtable."))) 125 :documentation "The data hashtable.")))
126;; Do this separately, since defclass doesn't allow expressions in :initform. 126;; Do this separately, since defclass doesn't allow expressions in :initform.
127(oset-default registry-db max-size most-positive-fixnum) 127(oset-default 'registry-db max-size most-positive-fixnum)
128 128
129(defmethod initialize-instance :BEFORE ((this registry-db) slots) 129(defmethod initialize-instance :BEFORE ((this registry-db) slots)
130 "Check whether a registry object needs to be upgraded." 130 "Check whether a registry object needs to be upgraded."
diff --git a/test/ChangeLog b/test/ChangeLog
index bb061478b30..83bb8bf00c7 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,57 @@
12015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use
4 <foo>-child-p.
5
6 * automated/eieio-test-methodinvoke.el (eieio-test-method-store):
7 Update reference to eieio--generic-call-key.
8
92015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
10
11 * automated/eieio-tests.el: Use cl-lib. Don't use <class> as a variable.
12 Don't use <class>-list types and <class>-list-p predicates.
13
14 * automated/eieio-test-persist.el (persistent-with-objs-list-slot):
15 Don't use <class>-list type.
16
17 * automated/eieio-test-methodinvoke.el
18 (eieio-test-method-order-list-4):
19 Don't use <class> as a variable.
20
212015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
22
23 * automated/eieio-tests.el (eieio-test-04-static-method)
24 (eieio-test-05-static-method-2): Use oref-default to access
25 class slots.
26 (eieio-test-23-inheritance-check): Don't assume that
27 eieio-class-parents returns class names, or that a class can only have
28 a single name.
29
30 * automated/eieio-test-persist.el (eieio--attribute-to-initarg):
31 Move from eieio-core.el. Rename from eieio-attribute-to-initarg.
32 Change arg to be a class object. Update all callers.
33
342015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
35
36 * automated/eieio-test-methodinvoke.el (eieio-test-method-store):
37 Adjust to new semantics of eieio--scoped-class.
38 (eieio-test-match): Improve error feedback.
39
402015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
41
42 * automated/eieio-tests.el: Remove dummy object names.
43
44 * automated/eieio-test-persist.el (persistent-with-objs-slot-subs):
45 The type FOO-child is the same as FOO.
46
472015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
48
49 * automated/eieio-test-methodinvoke.el (eieio-test-method-store):
50 Remove use of eieio-generic-call-methodname.
51 (eieio-test-method-order-list-3, eieio-test-method-order-list-6)
52 (eieio-test-method-order-list-7, eieio-test-method-order-list-8):
53 Adjust the expected result accordingly.
54
12015-01-01 Michael Albinus <michael.albinus@gmx.de> 552015-01-01 Michael Albinus <michael.albinus@gmx.de>
2 56
3 * automated/tramp-tests.el (tramp--test-smb-or-windows-nt-p): 57 * automated/tramp-tests.el (tramp--test-smb-or-windows-nt-p):
@@ -19,8 +73,7 @@
192014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> 732014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
20 74
21 * automated/python-tests.el 75 * automated/python-tests.el
22 (python-shell-completion-native-interpreter-disabled-p-1): New 76 (python-shell-completion-native-interpreter-disabled-p-1): New test.
23 test.
24 77
252014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> 782014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
26 79
@@ -110,8 +163,8 @@
110 (vc-test--create-repo-function): Rename from 163 (vc-test--create-repo-function): Rename from
111 `vc-test--create-repo-if-not-supported'. Adapt all callees. 164 `vc-test--create-repo-if-not-supported'. Adapt all callees.
112 (vc-test--create-repo): Check also for revision-granularity. 165 (vc-test--create-repo): Check also for revision-granularity.
113 (vc-test--unregister-function): Additional argument FILE. Adapt 166 (vc-test--unregister-function): Additional argument FILE.
114 all callees. 167 Adapt all callees.
115 (vc-test--working-revision): New defun. 168 (vc-test--working-revision): New defun.
116 (vc-test-*-working-revision): New tests. 169 (vc-test-*-working-revision): New tests.
117 170
@@ -148,7 +201,7 @@
1482014-11-21 Ulf Jasper <ulf.jasper@web.de> 2012014-11-21 Ulf Jasper <ulf.jasper@web.de>
149 202
150 * automated/libxml-tests.el 203 * automated/libxml-tests.el
151 (libxml-tests--data-comments-preserved): Renamed from 204 (libxml-tests--data-comments-preserved): Rename from
152 'libxml-tests--data'. 205 'libxml-tests--data'.
153 (libxml-tests--data-comments-discarded): New. 206 (libxml-tests--data-comments-discarded): New.
154 (libxml-tests): Check whether 'libxml-parse-xml-region' is 207 (libxml-tests): Check whether 'libxml-parse-xml-region' is
@@ -175,8 +228,8 @@
175 228
1762014-11-17 Ulf Jasper <ulf.jasper@web.de> 2292014-11-17 Ulf Jasper <ulf.jasper@web.de>
177 230
178 * automated/icalendar-tests.el (icalendar-tests--test-export): New 231 * automated/icalendar-tests.el (icalendar-tests--test-export):
179 optional parameter `alarms'. 232 New optional parameter `alarms'.
180 (icalendar-export-alarms): New test for exporting icalendar 233 (icalendar-export-alarms): New test for exporting icalendar
181 alarms. 234 alarms.
182 (icalendar-tests--test-cycle): Let `icalendar-export-alarms' be nil. 235 (icalendar-tests--test-cycle): Let `icalendar-export-alarms' be nil.
@@ -190,8 +243,8 @@
190 243
1912014-11-16 Ulf Jasper <ulf.jasper@web.de> 2442014-11-16 Ulf Jasper <ulf.jasper@web.de>
192 245
193 * automated/icalendar-tests.el (icalendar--parse-vtimezone): Add 246 * automated/icalendar-tests.el (icalendar--parse-vtimezone):
194 testcase where offsets of standard time and daylight saving time 247 Add testcase where offsets of standard time and daylight saving time
195 are equal. 248 are equal.
196 (icalendar-real-world): Fix error in test case. Expected result 249 (icalendar-real-world): Fix error in test case. Expected result
197 was wrong when offsets of standard time and daylight saving time 250 was wrong when offsets of standard time and daylight saving time
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el
index f2fe37836f3..2de836ceda5 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -61,16 +61,17 @@
61(defun eieio-test-method-store () 61(defun eieio-test-method-store ()
62 "Store current invocation class symbol in the invocation order list." 62 "Store current invocation class symbol in the invocation order list."
63 (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ] 63 (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
64 (or eieio-generic-call-key 0))) 64 (or eieio--generic-call-key 0)))
65 (c (list eieio-generic-call-methodname keysym (eieio--scoped-class)))) 65 ;; FIXME: Don't depend on `eieio--scoped-class'!
66 (setq eieio-test-method-order-list 66 (c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
67 (cons c eieio-test-method-order-list)))) 67 (push c eieio-test-method-order-list)))
68 68
69(defun eieio-test-match (rightanswer) 69(defun eieio-test-match (rightanswer)
70 "Do a test match." 70 "Do a test match."
71 (if (equal rightanswer eieio-test-method-order-list) 71 (if (equal rightanswer eieio-test-method-order-list)
72 t 72 t
73 (error "eieio-test-methodinvoke.el: Test Failed!"))) 73 (error "eieio-test-methodinvoke.el: Test Failed: %S != %S"
74 rightanswer eieio-test-method-order-list)))
74 75
75(defvar eieio-test-call-next-method-arguments nil 76(defvar eieio-test-call-next-method-arguments nil
76 "List of passed to methods during execution of `call-next-method'.") 77 "List of passed to methods during execution of `call-next-method'.")
@@ -121,17 +122,17 @@
121(ert-deftest eieio-test-method-order-list-3 () 122(ert-deftest eieio-test-method-order-list-3 ()
122 (let ((eieio-test-method-order-list nil) 123 (let ((eieio-test-method-order-list nil)
123 (ans '( 124 (ans '(
124 (eitest-F :BEFORE eitest-B) 125 (:BEFORE eitest-B)
125 (eitest-F :BEFORE eitest-B-base1) 126 (:BEFORE eitest-B-base1)
126 (eitest-F :BEFORE eitest-B-base2) 127 (:BEFORE eitest-B-base2)
127 128
128 (eitest-F :PRIMARY eitest-B) 129 (:PRIMARY eitest-B)
129 (eitest-F :PRIMARY eitest-B-base1) 130 (:PRIMARY eitest-B-base1)
130 (eitest-F :PRIMARY eitest-B-base2) 131 (:PRIMARY eitest-B-base2)
131 132
132 (eitest-F :AFTER eitest-B-base2) 133 (:AFTER eitest-B-base2)
133 (eitest-F :AFTER eitest-B-base1) 134 (:AFTER eitest-B-base1)
134 (eitest-F :AFTER eitest-B) 135 (:AFTER eitest-B)
135 ))) 136 )))
136 (eitest-F (eitest-B nil)) 137 (eitest-F (eitest-B nil))
137 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) 138 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
@@ -145,7 +146,7 @@
145 146
146(ert-deftest eieio-test-method-order-list-4 () 147(ert-deftest eieio-test-method-order-list-4 ()
147 ;; Both of these situations should succeed. 148 ;; Both of these situations should succeed.
148 (should (eitest-H eitest-A)) 149 (should (eitest-H 'eitest-A))
149 (should (eitest-H (eitest-A nil)))) 150 (should (eitest-H (eitest-A nil))))
150 151
151;;; Return value from :PRIMARY 152;;; Return value from :PRIMARY
@@ -176,17 +177,18 @@
176(defclass C-base2 () ()) 177(defclass C-base2 () ())
177(defclass C (C-base1 C-base2) ()) 178(defclass C (C-base1 C-base2) ())
178 179
180;; Just use the obsolete name once, to make sure it also works.
179(defmethod constructor :STATIC ((p C-base1) &rest args) 181(defmethod constructor :STATIC ((p C-base1) &rest args)
180 (eieio-test-method-store) 182 (eieio-test-method-store)
181 (if (next-method-p) (call-next-method)) 183 (if (next-method-p) (call-next-method))
182 ) 184 )
183 185
184(defmethod constructor :STATIC ((p C-base2) &rest args) 186(defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
185 (eieio-test-method-store) 187 (eieio-test-method-store)
186 (if (next-method-p) (call-next-method)) 188 (if (next-method-p) (call-next-method))
187 ) 189 )
188 190
189(defmethod constructor :STATIC ((p C) &rest args) 191(defmethod eieio-constructor :STATIC ((p C) &rest args)
190 (eieio-test-method-store) 192 (eieio-test-method-store)
191 (call-next-method) 193 (call-next-method)
192 ) 194 )
@@ -194,9 +196,9 @@
194(ert-deftest eieio-test-method-order-list-6 () 196(ert-deftest eieio-test-method-order-list-6 ()
195 (let ((eieio-test-method-order-list nil) 197 (let ((eieio-test-method-order-list nil)
196 (ans '( 198 (ans '(
197 (constructor :STATIC C) 199 (:STATIC C)
198 (constructor :STATIC C-base1) 200 (:STATIC C-base1)
199 (constructor :STATIC C-base2) 201 (:STATIC C-base2)
200 ))) 202 )))
201 (C nil) 203 (C nil)
202 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) 204 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
@@ -239,10 +241,10 @@
239(ert-deftest eieio-test-method-order-list-7 () 241(ert-deftest eieio-test-method-order-list-7 ()
240 (let ((eieio-test-method-order-list nil) 242 (let ((eieio-test-method-order-list nil)
241 (ans '( 243 (ans '(
242 (eitest-F :PRIMARY D) 244 (:PRIMARY D)
243 (eitest-F :PRIMARY D-base1) 245 (:PRIMARY D-base1)
244 ;; (eitest-F :PRIMARY D-base2) 246 ;; (:PRIMARY D-base2)
245 (eitest-F :PRIMARY D-base0) 247 (:PRIMARY D-base0)
246 ))) 248 )))
247 (eitest-F (D nil)) 249 (eitest-F (D nil))
248 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) 250 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
@@ -278,10 +280,10 @@
278(ert-deftest eieio-test-method-order-list-8 () 280(ert-deftest eieio-test-method-order-list-8 ()
279 (let ((eieio-test-method-order-list nil) 281 (let ((eieio-test-method-order-list nil)
280 (ans '( 282 (ans '(
281 (eitest-F :PRIMARY E) 283 (:PRIMARY E)
282 (eitest-F :PRIMARY E-base1) 284 (:PRIMARY E-base1)
283 (eitest-F :PRIMARY E-base2) 285 (:PRIMARY E-base2)
284 (eitest-F :PRIMARY E-base0) 286 (:PRIMARY E-base0)
285 ))) 287 )))
286 (eitest-F (E nil)) 288 (eitest-F (E nil))
287 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) 289 (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
diff --git a/test/automated/eieio-test-persist.el b/test/automated/eieio-test-persist.el
index 2db1dbe6698..7bb2f1ca779 100644
--- a/test/automated/eieio-test-persist.el
+++ b/test/automated/eieio-test-persist.el
@@ -32,6 +32,14 @@
32(require 'eieio-base) 32(require 'eieio-base)
33(require 'ert) 33(require 'ert)
34 34
35(defun eieio--attribute-to-initarg (class attribute)
36 "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
37This is usually a symbol that starts with `:'."
38 (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class))))
39 (if tuple
40 (car tuple)
41 nil)))
42
35(defun persist-test-save-and-compare (original) 43(defun persist-test-save-and-compare (original)
36 "Compare the object ORIGINAL against the one read fromdisk." 44 "Compare the object ORIGINAL against the one read fromdisk."
37 45
@@ -40,7 +48,7 @@
40 (let* ((file (oref original :file)) 48 (let* ((file (oref original :file))
41 (class (eieio-object-class original)) 49 (class (eieio-object-class original))
42 (fromdisk (eieio-persistent-read file class)) 50 (fromdisk (eieio-persistent-read file class))
43 (cv (class-v class)) 51 (cv (eieio--class-v class))
44 (slot-names (eieio--class-public-a cv)) 52 (slot-names (eieio--class-public-a cv))
45 (slot-deflt (eieio--class-public-d cv)) 53 (slot-deflt (eieio--class-public-d cv))
46 ) 54 )
@@ -53,7 +61,8 @@
53 (let* ((oneslot (car slot-names)) 61 (let* ((oneslot (car slot-names))
54 (origvalue (eieio-oref original oneslot)) 62 (origvalue (eieio-oref original oneslot))
55 (fromdiskvalue (eieio-oref fromdisk oneslot)) 63 (fromdiskvalue (eieio-oref fromdisk oneslot))
56 (initarg-p (eieio-attribute-to-initarg class oneslot)) 64 (initarg-p (eieio--attribute-to-initarg
65 (eieio--class-v class) oneslot))
57 ) 66 )
58 67
59 (if initarg-p 68 (if initarg-p
@@ -175,7 +184,7 @@ persistent class.")
175 184
176(defclass persistent-with-objs-slot-subs (eieio-persistent) 185(defclass persistent-with-objs-slot-subs (eieio-persistent)
177 ((pnp :initarg :pnp 186 ((pnp :initarg :pnp
178 :type (or null persist-not-persistent-child) 187 :type (or null persist-not-persistent)
179 :initform nil)) 188 :initform nil))
180 "Class for testing the saving of slots with objects in them.") 189 "Class for testing the saving of slots with objects in them.")
181 190
@@ -194,7 +203,7 @@ persistent class.")
194;; A slot that contains another object that isn't persistent 203;; A slot that contains another object that isn't persistent
195(defclass persistent-with-objs-list-slot (eieio-persistent) 204(defclass persistent-with-objs-list-slot (eieio-persistent)
196 ((pnp :initarg :pnp 205 ((pnp :initarg :pnp
197 :type persist-not-persistent-list 206 :type (list-of persist-not-persistent)
198 :initform nil)) 207 :initform nil))
199 "Class for testing the saving of slots with objects in them.") 208 "Class for testing the saving of slots with objects in them.")
200 209
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el
index 15b65042ba4..0b1ff1fd93b 100644
--- a/test/automated/eieio-tests.el
+++ b/test/automated/eieio-tests.el
@@ -29,7 +29,7 @@
29(require 'eieio-base) 29(require 'eieio-base)
30(require 'eieio-opt) 30(require 'eieio-opt)
31 31
32(eval-when-compile (require 'cl)) 32(eval-when-compile (require 'cl-lib))
33 33
34;;; Code: 34;;; Code:
35;; Set up some test classes 35;; Set up some test classes
@@ -158,7 +158,7 @@
158(ert-deftest eieio-test-02-abstract-class () 158(ert-deftest eieio-test-02-abstract-class ()
159 ;; Abstract classes cannot be instantiated, so this should throw an 159 ;; Abstract classes cannot be instantiated, so this should throw an
160 ;; error 160 ;; error
161 (should-error (abstract-class "Test"))) 161 (should-error (abstract-class)))
162 162
163(defgeneric generic1 () "First generic function") 163(defgeneric generic1 () "First generic function")
164 164
@@ -180,7 +180,7 @@
180 "Method generic1 that can take a non-object." 180 "Method generic1 that can take a non-object."
181 not-an-object) 181 not-an-object)
182 182
183 (let ((ans-obj (generic1 (class-a "test"))) 183 (let ((ans-obj (generic1 (class-a)))
184 (ans-num (generic1 666))) 184 (ans-num (generic1 666)))
185 (should (eq ans-obj 'monkey)) 185 (should (eq ans-obj 'monkey))
186 (should (eq ans-num 666)))) 186 (should (eq ans-num 666))))
@@ -199,10 +199,10 @@ Argument C is the class bound to this static method."
199 199
200(ert-deftest eieio-test-04-static-method () 200(ert-deftest eieio-test-04-static-method ()
201 ;; Call static method on a class and see if it worked 201 ;; Call static method on a class and see if it worked
202 (static-method-class-method static-method-class 'class) 202 (static-method-class-method 'static-method-class 'class)
203 (should (eq (oref static-method-class some-slot) 'class)) 203 (should (eq (oref-default 'static-method-class some-slot) 'class))
204 (static-method-class-method (static-method-class "test") 'object) 204 (static-method-class-method (static-method-class) 'object)
205 (should (eq (oref static-method-class some-slot) 'object))) 205 (should (eq (oref-default 'static-method-class some-slot) 'object)))
206 206
207(ert-deftest eieio-test-05-static-method-2 () 207(ert-deftest eieio-test-05-static-method-2 ()
208 (defclass static-method-class-2 (static-method-class) 208 (defclass static-method-class-2 (static-method-class)
@@ -215,10 +215,10 @@ Argument C is the class bound to this static method."
215 (if (eieio-object-p c) (setq c (eieio-object-class c))) 215 (if (eieio-object-p c) (setq c (eieio-object-class c)))
216 (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) 216 (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
217 217
218 (static-method-class-method static-method-class-2 'class) 218 (static-method-class-method 'static-method-class-2 'class)
219 (should (eq (oref static-method-class-2 some-slot) 'moose-class)) 219 (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
220 (static-method-class-method (static-method-class-2 "test") 'object) 220 (static-method-class-method (static-method-class-2) 'object)
221 (should (eq (oref static-method-class-2 some-slot) 'moose-object))) 221 (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
222 222
223 223
224;;; Perform method testing 224;;; Perform method testing
@@ -231,14 +231,14 @@ Argument C is the class bound to this static method."
231(defvar eitest-b nil) 231(defvar eitest-b nil)
232(ert-deftest eieio-test-06-allocate-objects () 232(ert-deftest eieio-test-06-allocate-objects ()
233 ;; allocate an object to use 233 ;; allocate an object to use
234 (should (setq eitest-ab (class-ab "abby"))) 234 (should (setq eitest-ab (class-ab)))
235 (should (setq eitest-a (class-a "aye"))) 235 (should (setq eitest-a (class-a)))
236 (should (setq eitest-b (class-b "fooby")))) 236 (should (setq eitest-b (class-b))))
237 237
238(ert-deftest eieio-test-07-make-instance () 238(ert-deftest eieio-test-07-make-instance ()
239 (should (make-instance 'class-ab)) 239 (should (make-instance 'class-ab))
240 (should (make-instance 'class-a :water 'cho)) 240 (should (make-instance 'class-a :water 'cho))
241 (should (make-instance 'class-b "a name"))) 241 (should (make-instance 'class-b)))
242 242
243(defmethod class-cn ((a class-a)) 243(defmethod class-cn ((a class-a))
244 "Try calling `call-next-method' when there isn't one. 244 "Try calling `call-next-method' when there isn't one.
@@ -355,7 +355,7 @@ METHOD is the method that was attempting to be called."
355 (call-next-method) 355 (call-next-method)
356 (oset a test-tag 1)) 356 (oset a test-tag 1))
357 357
358 (let ((ca (class-a "class act"))) 358 (let ((ca (class-a)))
359 (should-not (/= (oref ca test-tag) 2)))) 359 (should-not (/= (oref ca test-tag) 2))))
360 360
361 361
@@ -404,7 +404,7 @@ METHOD is the method that was attempting to be called."
404 (t (call-next-method)))) 404 (t (call-next-method))))
405 405
406(ert-deftest eieio-test-17-virtual-slot () 406(ert-deftest eieio-test-17-virtual-slot ()
407 (setq eitest-vsca (virtual-slot-class "eitest-vsca" :base-value 1)) 407 (setq eitest-vsca (virtual-slot-class :base-value 1))
408 ;; Check slot values 408 ;; Check slot values
409 (should (= (oref eitest-vsca :base-value) 1)) 409 (should (= (oref eitest-vsca :base-value) 1))
410 (should (= (oref eitest-vsca :derived-value) 2)) 410 (should (= (oref eitest-vsca :derived-value) 2))
@@ -419,7 +419,7 @@ METHOD is the method that was attempting to be called."
419 419
420 ;; should also be possible to initialize instance using virtual slot 420 ;; should also be possible to initialize instance using virtual slot
421 421
422 (setq eitest-vscb (virtual-slot-class "eitest-vscb" :derived-value 5)) 422 (setq eitest-vscb (virtual-slot-class :derived-value 5))
423 (should (= (oref eitest-vscb :base-value) 4)) 423 (should (= (oref eitest-vscb :base-value) 4))
424 (should (= (oref eitest-vscb :derived-value) 5))) 424 (should (= (oref eitest-vscb :derived-value) 5)))
425 425
@@ -445,7 +445,7 @@ METHOD is the method that was attempting to be called."
445 ;; After setting 'water to 'moose, make sure a new object has 445 ;; After setting 'water to 'moose, make sure a new object has
446 ;; the right stuff. 446 ;; the right stuff.
447 (oset-default (eieio-object-class eitest-a) water 'penguin) 447 (oset-default (eieio-object-class eitest-a) water 'penguin)
448 (should (eq (oref (class-a "foo") water) 'penguin)) 448 (should (eq (oref (class-a) water) 'penguin))
449 449
450 ;; Revert the above 450 ;; Revert the above
451 (defmethod slot-unbound ((a class-a) &rest foo) 451 (defmethod slot-unbound ((a class-a) &rest foo)
@@ -459,12 +459,12 @@ METHOD is the method that was attempting to be called."
459 ;; We should not be able to set a string here 459 ;; We should not be able to set a string here
460 (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type) 460 (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
461 (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type) 461 (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
462 (should-error (class-a "broken-type-a" :water "a string not a symbol") :type 'invalid-slot-type)) 462 (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type))
463 463
464(ert-deftest eieio-test-20-class-allocated-slots () 464(ert-deftest eieio-test-20-class-allocated-slots ()
465 ;; Test out class allocated slots 465 ;; Test out class allocated slots
466 (defvar eitest-aa nil) 466 (defvar eitest-aa nil)
467 (setq eitest-aa (class-a "another")) 467 (setq eitest-aa (class-a))
468 468
469 ;; Make sure class slots do not track between objects 469 ;; Make sure class slots do not track between objects
470 (let ((newval 'moose)) 470 (let ((newval 'moose))
@@ -474,12 +474,12 @@ METHOD is the method that was attempting to be called."
474 474
475 ;; Slot should be bound 475 ;; Slot should be bound
476 (should (slot-boundp eitest-a 'classslot)) 476 (should (slot-boundp eitest-a 'classslot))
477 (should (slot-boundp class-a 'classslot)) 477 (should (slot-boundp 'class-a 'classslot))
478 478
479 (slot-makeunbound eitest-a 'classslot) 479 (slot-makeunbound eitest-a 'classslot)
480 480
481 (should-not (slot-boundp eitest-a 'classslot)) 481 (should-not (slot-boundp eitest-a 'classslot))
482 (should-not (slot-boundp class-a 'classslot))) 482 (should-not (slot-boundp 'class-a 'classslot)))
483 483
484 484
485(defvar eieio-test-permuting-value nil) 485(defvar eieio-test-permuting-value nil)
@@ -499,7 +499,7 @@ METHOD is the method that was attempting to be called."
499(ert-deftest eieio-test-21-eval-at-construction-time () 499(ert-deftest eieio-test-21-eval-at-construction-time ()
500 ;; initforms that need to be evalled at construction time. 500 ;; initforms that need to be evalled at construction time.
501 (setq eieio-test-permuting-value 2) 501 (setq eieio-test-permuting-value 2)
502 (setq eitest-pvinit (inittest "permuteme")) 502 (setq eitest-pvinit (inittest))
503 503
504 (should (eq (oref eitest-pvinit staticval) 1)) 504 (should (eq (oref eitest-pvinit staticval) 1))
505 (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value)) 505 (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
@@ -515,11 +515,11 @@ METHOD is the method that was attempting to be called."
515 "Test class that will be a calculated value.") 515 "Test class that will be a calculated value.")
516 516
517 (defclass eitest-superior nil 517 (defclass eitest-superior nil
518 ((sub :initform (eitest-subordinate "test") 518 ((sub :initform (eitest-subordinate)
519 :type eitest-subordinate)) 519 :type eitest-subordinate))
520 "A class with an initform that creates a class.") 520 "A class with an initform that creates a class.")
521 521
522 (should (setq eitest-tests (eitest-superior "test"))) 522 (should (setq eitest-tests (eitest-superior)))
523 523
524 (should-error 524 (should-error
525 (eval 525 (eval
@@ -530,33 +530,35 @@ METHOD is the method that was attempting to be called."
530 :type 'invalid-slot-type)) 530 :type 'invalid-slot-type))
531 531
532(ert-deftest eieio-test-23-inheritance-check () 532(ert-deftest eieio-test-23-inheritance-check ()
533 (should (child-of-class-p class-ab class-a)) 533 (should (child-of-class-p 'class-ab 'class-a))
534 (should (child-of-class-p class-ab class-b)) 534 (should (child-of-class-p 'class-ab 'class-b))
535 (should (object-of-class-p eitest-a class-a)) 535 (should (object-of-class-p eitest-a 'class-a))
536 (should (object-of-class-p eitest-ab class-a)) 536 (should (object-of-class-p eitest-ab 'class-a))
537 (should (object-of-class-p eitest-ab class-b)) 537 (should (object-of-class-p eitest-ab 'class-b))
538 (should (object-of-class-p eitest-ab class-ab)) 538 (should (object-of-class-p eitest-ab 'class-ab))
539 (should (eq (eieio-class-parents class-a) nil)) 539 (should (eq (eieio-class-parents 'class-a) nil))
540 (should (equal (eieio-class-parents class-ab) '(class-a class-b))) 540 ;; FIXME: eieio-class-parents now returns class objects!
541 (should (same-class-p eitest-a class-a)) 541 (should (equal (mapcar #'eieio-class-object (eieio-class-parents 'class-ab))
542 (mapcar #'eieio-class-object '(class-a class-b))))
543 (should (same-class-p eitest-a 'class-a))
542 (should (class-a-p eitest-a)) 544 (should (class-a-p eitest-a))
543 (should (not (class-a-p eitest-ab))) 545 (should (not (class-a-p eitest-ab)))
544 (should (class-a-child-p eitest-a)) 546 (should (cl-typep eitest-a 'class-a))
545 (should (class-a-child-p eitest-ab)) 547 (should (cl-typep eitest-ab 'class-a))
546 (should (not (class-a-p "foo"))) 548 (should (not (class-a-p "foo")))
547 (should (not (class-a-child-p "foo")))) 549 (should (not (cl-typep "foo" 'class-a))))
548 550
549(ert-deftest eieio-test-24-object-predicates () 551(ert-deftest eieio-test-24-object-predicates ()
550 (let ((listooa (list (class-ab "ab") (class-a "a"))) 552 (let ((listooa (list (class-ab) (class-a)))
551 (listoob (list (class-ab "ab") (class-b "b")))) 553 (listoob (list (class-ab) (class-b))))
552 (should (class-a-list-p listooa)) 554 (should (cl-typep listooa '(list-of class-a)))
553 (should (class-b-list-p listoob)) 555 (should (cl-typep listoob '(list-of class-b)))
554 (should-not (class-b-list-p listooa)) 556 (should-not (cl-typep listooa '(list-of class-b)))
555 (should-not (class-a-list-p listoob)))) 557 (should-not (cl-typep listoob '(list-of class-a)))))
556 558
557(defvar eitest-t1 nil) 559(defvar eitest-t1 nil)
558(ert-deftest eieio-test-25-slot-tests () 560(ert-deftest eieio-test-25-slot-tests ()
559 (setq eitest-t1 (class-c "C1")) 561 (setq eitest-t1 (class-c))
560 ;; Slot initialization 562 ;; Slot initialization
561 (should (eq (oref eitest-t1 slot-1) 'moose)) 563 (should (eq (oref eitest-t1 slot-1) 'moose))
562 (should (eq (oref eitest-t1 :moose) 'moose)) 564 (should (eq (oref eitest-t1 :moose) 'moose))
@@ -565,9 +567,9 @@ METHOD is the method that was attempting to be called."
565 ;; Check private slot accessor 567 ;; Check private slot accessor
566 (should (string= (get-slot-2 eitest-t1) "penguin")) 568 (should (string= (get-slot-2 eitest-t1) "penguin"))
567 ;; Pass string instead of symbol 569 ;; Pass string instead of symbol
568 (should-error (class-c "C2" :moose "not a symbol") :type 'invalid-slot-type) 570 (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
569 (should (eq (get-slot-3 eitest-t1) 'emu)) 571 (should (eq (get-slot-3 eitest-t1) 'emu))
570 (should (eq (get-slot-3 class-c) 'emu)) 572 (should (eq (get-slot-3 'class-c) 'emu))
571 ;; Check setf 573 ;; Check setf
572 (setf (get-slot-3 eitest-t1) 'setf-emu) 574 (setf (get-slot-3 eitest-t1) 'setf-emu)
573 (should (eq (get-slot-3 eitest-t1) 'setf-emu)) 575 (should (eq (get-slot-3 eitest-t1) 'setf-emu))
@@ -577,13 +579,13 @@ METHOD is the method that was attempting to be called."
577(defvar eitest-t2 nil) 579(defvar eitest-t2 nil)
578(ert-deftest eieio-test-26-default-inheritance () 580(ert-deftest eieio-test-26-default-inheritance ()
579 ;; See previous test, nor for subclass 581 ;; See previous test, nor for subclass
580 (setq eitest-t2 (class-subc "subc")) 582 (setq eitest-t2 (class-subc))
581 (should (eq (oref eitest-t2 slot-1) 'moose)) 583 (should (eq (oref eitest-t2 slot-1) 'moose))
582 (should (eq (oref eitest-t2 :moose) 'moose)) 584 (should (eq (oref eitest-t2 :moose) 'moose))
583 (should (string= (get-slot-2 eitest-t2) "linux")) 585 (should (string= (get-slot-2 eitest-t2) "linux"))
584 (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) 586 (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
585 (should (string= (get-slot-2 eitest-t2) "linux")) 587 (should (string= (get-slot-2 eitest-t2) "linux"))
586 (should-error (class-subc "C2" :moose "not a symbol") :type 'invalid-slot-type)) 588 (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
587 589
588;;(ert-deftest eieio-test-27-inherited-new-value () 590;;(ert-deftest eieio-test-27-inherited-new-value ()
589 ;;; HACK ALERT: The new value of a class slot is inherited by the 591 ;;; HACK ALERT: The new value of a class slot is inherited by the
@@ -647,8 +649,8 @@ Do not override for `prot-2'."
647(defvar eitest-p1 nil) 649(defvar eitest-p1 nil)
648(defvar eitest-p2 nil) 650(defvar eitest-p2 nil)
649(ert-deftest eieio-test-28-slot-protection () 651(ert-deftest eieio-test-28-slot-protection ()
650 (setq eitest-p1 (prot-1 "")) 652 (setq eitest-p1 (prot-1))
651 (setq eitest-p2 (prot-2 "")) 653 (setq eitest-p2 (prot-2))
652 ;; Access public slots 654 ;; Access public slots
653 (oref eitest-p1 slot-1) 655 (oref eitest-p1 slot-1)
654 (oref eitest-p2 slot-1) 656 (oref eitest-p2 slot-1)
@@ -743,7 +745,7 @@ Subclasses to override slot attributes.")
743 "This class should throw an error."))) 745 "This class should throw an error.")))
744 746
745 ;; Initform should override instance allocation 747 ;; Initform should override instance allocation
746 (let ((obj (slotattr-ok "moose"))) 748 (let ((obj (slotattr-ok)))
747 (should (eq (oref obj initform) 'no-init)))) 749 (should (eq (oref obj initform) 'no-init))))
748 750
749(defclass slotattr-class-base () 751(defclass slotattr-class-base ()
@@ -792,10 +794,10 @@ Subclasses to override slot attributes.")
792 ((type :type string) 794 ((type :type string)
793 ) 795 )
794 "This class should throw an error."))) 796 "This class should throw an error.")))
795 (should (eq (oref-default slotattr-class-ok initform) 'no-init))) 797 (should (eq (oref-default 'slotattr-class-ok initform) 'no-init)))
796 798
797(ert-deftest eieio-test-32-slot-attribute-override-2 () 799(ert-deftest eieio-test-32-slot-attribute-override-2 ()
798 (let* ((cv (class-v 'slotattr-ok)) 800 (let* ((cv (eieio--class-v 'slotattr-ok))
799 (docs (eieio--class-public-doc cv)) 801 (docs (eieio--class-public-doc cv))
800 (names (eieio--class-public-a cv)) 802 (names (eieio--class-public-a cv))
801 (cust (eieio--class-public-custom cv)) 803 (cust (eieio--class-public-custom cv))
@@ -826,7 +828,7 @@ Subclasses to override slot attributes.")
826 828
827(ert-deftest eieio-test-32-test-clone-boring-objects () 829(ert-deftest eieio-test-32-test-clone-boring-objects ()
828 ;; A simple make instance with EIEIO extension 830 ;; A simple make instance with EIEIO extension
829 (should (setq eitest-CLONETEST1 (make-instance 'class-a "a"))) 831 (should (setq eitest-CLONETEST1 (make-instance 'class-a)))
830 (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))) 832 (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
831 833
832 ;; CLOS form of make-instance 834 ;; CLOS form of make-instance
@@ -840,7 +842,7 @@ Subclasses to override slot attributes.")
840 842
841(ert-deftest eieio-test-33-instance-tracker () 843(ert-deftest eieio-test-33-instance-tracker ()
842 (let (IT-list IT1) 844 (let (IT-list IT1)
843 (should (setq IT1 (IT "trackme"))) 845 (should (setq IT1 (IT)))
844 ;; The instance tracker must find this 846 ;; The instance tracker must find this
845 (should (eieio-instance-tracker-find 'die 'slot1 'IT-list)) 847 (should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
846 ;; Test deletion 848 ;; Test deletion
@@ -852,8 +854,8 @@ Subclasses to override slot attributes.")
852 "A Singleton test object.") 854 "A Singleton test object.")
853 855
854(ert-deftest eieio-test-34-singletons () 856(ert-deftest eieio-test-34-singletons ()
855 (let ((obj1 (SINGLE "Moose")) 857 (let ((obj1 (SINGLE))
856 (obj2 (SINGLE "Cow"))) 858 (obj2 (SINGLE)))
857 (should (eieio-object-p obj1)) 859 (should (eieio-object-p obj1))
858 (should (eieio-object-p obj2)) 860 (should (eieio-object-p obj2))
859 (should (eq obj1 obj2)) 861 (should (eq obj1 obj2))
@@ -866,7 +868,7 @@ Subclasses to override slot attributes.")
866 868
867(ert-deftest eieio-test-35-named-object () 869(ert-deftest eieio-test-35-named-object ()
868 (let (N) 870 (let (N)
869 (should (setq N (NAMED "Foo"))) 871 (should (setq N (NAMED :object-name "Foo")))
870 (should (string= "Foo" (oref N object-name))) 872 (should (string= "Foo" (oref N object-name)))
871 (should-error (oref N missing-slot) :type 'invalid-slot-name) 873 (should-error (oref N missing-slot) :type 'invalid-slot-name)
872 (oset N object-name "NewName") 874 (oset N object-name "NewName")
@@ -882,8 +884,8 @@ Subclasses to override slot attributes.")
882 "Instantiable child") 884 "Instantiable child")
883 885
884(ert-deftest eieio-test-36-build-class-alist () 886(ert-deftest eieio-test-36-build-class-alist ()
885 (should (= (length (eieio-build-class-alist opt-test1 nil)) 2)) 887 (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
886 (should (= (length (eieio-build-class-alist opt-test1 t)) 1))) 888 (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
887 889
888(provide 'eieio-tests) 890(provide 'eieio-tests)
889 891