aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog355
-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/files.el32
-rw-r--r--lisp/gnus/ChangeLog14
-rw-r--r--lisp/gnus/gnus-group.el42
-rw-r--r--lisp/gnus/registry.el2
-rw-r--r--lisp/international/ccl.el49
-rw-r--r--lisp/minibuffer.el29
-rw-r--r--lisp/net/eww.el15
-rw-r--r--lisp/net/shr.el7
-rw-r--r--lisp/progmodes/js.el5
-rw-r--r--lisp/progmodes/xref.el3
-rw-r--r--lisp/shell.el9
-rw-r--r--lisp/simple.el12
-rw-r--r--lisp/subr.el1
-rw-r--r--lisp/vc/vc-hooks.el2
48 files changed, 2419 insertions, 2012 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index f413526c0b2..674b26716a4 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,7 +1,319 @@
12015-01-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
2
3 * net/shr.el (shr-urlify): Don't bother the user about
4 invalidly-encoded display strings.
5
62015-01-10 Ivan Shmakov <ivan@siamics.net>
7
8 * net/shr.el (shr-urlify): Decode URLs before using them as titles
9 (bug#19555).
10
112015-01-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
12
13 * net/eww.el (eww): Always interpret URLs that start with https?:
14 as plain URLs, even if they have spaces in them (bug#19556).
15 (eww): Also interpret things like "en.wikipedia.org/wiki/Free
16 software" as an URL.
17 (eww): Don't interpret "org/foo" as an URL.
18 (eww): Clear the title when loading so that we don't display
19 misleading information.
20
212015-01-10 Daniel Colascione <dancol@dancol.org>
22
23 * vc/vc-hooks.el (vc-prefix-map): Bind vc-delete-file to C-x v x,
24 by analogy with dired.
25
262015-01-09 Daniel Colascione <dancol@dancol.org>
27
28 * progmodes/js.el (js--function-heading-1-re)
29 (js--function-prologue-beginning): Parse ES6 generator function
30 declarations. (That is, "function* name()").
31
322015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
33
34 * emacs-lisp/eieio.el (defclass): Move from eieio-defclass all the code
35 that creates functions, and most of the sanity checks.
36 Mark as obsolete the <class>-child-p function.
37 * emacs-lisp/eieio-core.el (eieio--define-field-accessors): Remove.
38 (eieio--class, eieio--object): Use cl-defstruct.
39 (eieio--object-num-slots): Define manually.
40 (eieio-defclass-autoload): Use eieio--class-make.
41 (eieio-defclass-internal): Rename from eieio-defclass. Move all the
42 `(lambda...) definitions and most of the sanity checks to `defclass'.
43 Mark as obsolete the <class>-list-p function, the <class> variable and
44 the <initarg> variables. Use pcase-dolist.
45 (eieio-defclass): New compatibility function.
46 * emacs-lisp/eieio-opt.el (eieio-build-class-alist)
47 (eieio-class-speedbar): Don't use eieio-default-superclass var.
48
492015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
50
51 * emacs-lisp/eieio-generic.el: New file.
52 * emacs-lisp/eieio-core.el: Move all generic function code to
53 eieio-generic.el.
54 (eieio--defmethod): Declare.
55
56 * emacs-lisp/eieio.el: Require eieio-generic. Move all generic
57 function code to eieio-generic.el.
58 * emacs-lisp/eieio-opt.el (eieio-help-generic): Move to
59 eieio-generic.el.
60 * emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke): Update call
61 to eieio--generic-call.
62 * emacs-lisp/eieio-base.el (eieio-instance-inheritor): Don't use
63 <class>-child type.
64
652015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
66
67 * emacs-lisp/chart.el (chart-add-sequence, chart-bar-quickie):
68 Don't use <class> as a variable.
69
70 * emacs-lisp/eieio.el (same-class-p): Accept class object as well.
71 (call-next-method): Simplify.
72 (clone): Obey eieio-backward-compatibility.
73
74 * emacs-lisp/eieio-opt.el (eieio-read-generic-p): Remove.
75 (eieio-read-generic): Use `generic-p' instead.
76
77 * emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var.
78 (eieio-defclass-autoload): Obey it.
79 (eieio--class-object): Improve error behavior.
80 (eieio-class-children-fast, same-class-fast-p): Remove. Inline at
81 every use site.
82 (eieio--defgeneric-form-primary-only): Rename from
83 eieio-defgeneric-form-primary-only; update all callers.
84 (eieio--defgeneric-form-primary-only-one): Rename from
85 eieio-defgeneric-form-primary-only-one; update all callers.
86 (eieio-defgeneric-reset-generic-form)
87 (eieio-defgeneric-reset-generic-form-primary-only)
88 (eieio-defgeneric-reset-generic-form-primary-only-one): Remove.
89 (eieio--method-optimize-primary): New function to replace them.
90 (eieio--defmethod, eieio-defmethod): Use it.
91 (eieio--perform-slot-validation): Rename from
92 eieio-perform-slot-validation; update all callers.
93 (eieio--validate-slot-value): Rename from eieio-validate-slot-value.
94 Change `class' to be a class object. Update all callers.
95 (eieio--validate-class-slot-value): Rename from
96 eieio-validate-class-slot-value. Change `class' to be a class object.
97 Update all callers.
98 (eieio-oset-default): Accept class object as well.
99 (eieio--generic-call-primary-only): Rename from
100 eieio-generic-call-primary-only. Update all callers.
101
102 * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
103 Improve error messages.
104 (eieio-persistent-slot-type-is-class-p): Handle `list-of' types, as
105 well as user-defined types. Emit errors for legacy types like
106 <class>-child and <class>-list, if not eieio-backward-compatibility.
107
1082015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
109
110 * emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
111 (eieio--class-slot-initarg): Rename from class-slot-initarg.
112 Change `class' arg to be a class object. Update all callers.
113 (call-next-method): Adjust to new return value of `eieio-generic-form'.
114 (eieio-default-superclass): Set var to the class object.
115 (eieio-edebug-prin1-to-string): Fix recursive call for lists.
116 Change print behavior to affect class objects rather than
117 class symbols.
118
119 * emacs-lisp/eieio-core.el (eieio-class-object): New function.
120 (eieio-class-parents-fast): Remove macro.
121 (eieio--class-option-assoc): Rename from class-option-assoc.
122 Update all callers.
123 (eieio--class-option): Rename from class-option. Change `class' arg to
124 be a class object. Update all callers.
125 (eieio--class-method-invocation-order): Rename from
126 class-method-invocation-order. Change `class' arg to be a class
127 object. Update all callers.
128 (eieio-defclass-autoload, eieio-defclass): Set the `parent' field to
129 a list of class objects rather than names.
130 (eieio-defclass): Remove redundant quotes. Use `eieio-oref-default'
131 for accessors to class allocated slots.
132 (eieio--perform-slot-validation-for-default): Rename from
133 eieio-perform-slot-validation-for-default. Update all callers.
134 (eieio--add-new-slot): Rename from eieio-add-new-slot.
135 Update all callers. Use push.
136 (eieio-copy-parents-into-subclass): Adjust to new content of
137 `parent' field. Use dolist.
138 (eieio-oref): Remove support for providing a class rather than
139 an object.
140 (eieio-oref-default): Prefer class objects over class names.
141 (eieio--slot-originating-class-p): Rename from
142 eieio-slot-originating-class-p. Update all callers. Use `or'.
143 (eieio--slot-name-index): Turn check into assertion.
144 (eieio--class-slot-name-index): Rename from
145 eieio-class-slot-name-index. Change `class' arg to be a class object.
146 Update all callers.
147 (eieio-attribute-to-initarg): Move to eieio-test-persist.el.
148 (eieio--c3-candidate): Rename from eieio-c3-candidate.
149 Update all callers.
150 (eieio--c3-merge-lists): Rename from eieio-c3-merge-lists.
151 Update all callers.
152 (eieio--class-precedence-c3): Rename from eieio-class-precedence-c3.
153 Update all callers.
154 (eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs.
155 Update all callers.
156 (eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs.
157 Update all callers. Adjust to new `parent' content.
158 (eieio--class-precedence-list): Rename from -class-precedence-list.
159 Update all callers.
160 (eieio-generic-call): Use autoloadp and autoload-do-load.
161 Slight simplification.
162 (eieio-generic-call, eieio-generic-call-primary-only): Adjust to new
163 return value of `eieio-generic-form'.
164 (eieiomt-add): Index the hashtable with class objects rather than
165 class names.
166 (eieio-generic-form): Accept class objects as well.
167
168 * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
169 Adjust to new convention for eieio-persistent-validate/fix-slot-value.
170 (eieio-persistent-validate/fix-slot-value):
171 Change `class' arg to be a class object. Update all callers.
172
1732015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
174
175 * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects
176 additionally to class names.
177
178 * emacs-lisp/eieio-core.el (eieio--with-scoped-class): Use let-binding.
179 (object): Remove first (constant) slot; rename second to `class-tag'.
180 (eieio--object-class-object, eieio--object-class-name): New funs
181 to replace eieio--object-class.
182 (eieio--class-object, eieio--class-p): New functions.
183 (same-class-fast-p): Make it a defsubst, change its implementation
184 to check the class objects rather than their names.
185 (eieio-object-p): Rewrite.
186 (eieio-defclass): Adjust the object initialization according to the new
187 object layout.
188 (eieio--scoped-class): Declare it returns a class object (not a class
189 name any more). Adjust calls accordingly (along with calls to
190 eieio--with-scoped-class).
191 (eieio--slot-name-index): Rename from eieio-slot-name-index and change
192 its class arg to be a class object. Adjust callers accordingly.
193 (eieio-slot-originating-class-p): Make its start-class arg a class
194 object. Adjust all callers.
195 (eieio--initarg-to-attribute): Rename from eieio-initarg-to-attribute.
196 Make its `class' arg a class object. Adjust all callers.
197
198 * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value):
199 Use eieio--slot-name-index rather than eieio-slot-name-index.
200
2012015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
202
203 * emacs-lisp/eieio.el (make-instance): Simplify by not adding an object
204 name argument.
205 (eieio-object-name): Use eieio-object-name-string.
206 (eieio--object-names): New const.
207 (eieio-object-name-string, eieio-object-set-name-string): Re-implement
208 using a hashtable rather than a built-in slot.
209 (eieio-constructor): Rename from `constructor'. Remove `newname' arg.
210 (clone): Don't mess with the object's "name".
211
212 * emacs-lisp/eieio-custom.el (eieio-widget-test): Remove dummy arg.
213 (eieio-object-value-get): Use eieio-object-set-name-string.
214
215 * emacs-lisp/eieio-core.el (eieio--defalias): Follow aliases.
216 (eieio--object): Remove `name' field.
217 (eieio-defclass): Adjust to new convention where constructors don't
218 take an "object name" any more.
219 (eieio--defgeneric-init-form, eieio--defmethod): Follow aliases.
220 (eieio-validate-slot-value, eieio-oset-default)
221 (eieio-slot-name-index): Don't hardcode eieio--object-num-slots.
222 (eieio-generic-call-primary-only): Simplify.
223
224 * emacs-lisp/eieio-base.el (clone) <eieio-instance-inheritor>:
225 Use call-next-method.
226 (eieio-constructor): Rename from `constructor'.
227 (eieio-persistent-convert-list-to-object): Drop objname.
228 (eieio-persistent-validate/fix-slot-value): Don't hardcode
229 eieio--object-num-slots.
230 (eieio-named): Use a normal slot.
231 (slot-missing) <eieio-named>: Remove.
232 (eieio-object-name-string, eieio-object-set-name-string, clone)
233 <eieio-named>: New methods.
234
2352015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
236
237 * emacs-lisp/eieio-core.el (eieio--class-v): Rename from class-v.
238 (method-*): Add a "eieio--" prefix to those constants.
239
240 * emacs-lisp/eieio.el: Move edebug specs to the corresponding macro.
241
242 * emacs-lisp/eieio-speedbar.el: Use lexical-binding.
243
2442015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
245
246 * emacs-lisp/eieio.el (child-of-class-p): Fix case where `class' is
247 `eieio-default-superclass'.
248
249 * emacs-lisp/eieio-datadebug.el: Use lexical-binding.
250
251 * emacs-lisp/eieio-custom.el: Use lexical-binding.
252 (eieio-object-value-to-abstract): Simplify.
253
254 * emacs-lisp/eieio-opt.el (eieio-build-class-list): Use cl-mapcan.
255 (eieio-build-class-alist): Use dolist.
256 (eieio-all-generic-functions): Adjust to use of hashtables.
257
258 * emacs-lisp/eieio-core.el (class): Rename field symbol-obarray to
259 symbol-hashtable. It contains a hashtable instead of an obarray.
260 (generic-p): Use symbol property `eieio-method-hashtable' instead of
261 `eieio-method-obarray'.
262 (generic-primary-only-p, generic-primary-only-one-p):
263 Slight optimization.
264 (eieio-defclass-autoload-map): Use a hashtable instead of an obarray.
265 (eieio-defclass-autoload, eieio-defclass): Adjust/simplify accordingly.
266 (eieio-class-un-autoload): Use autoload-do-load.
267 (eieio-defclass): Use dolist, cl-pushnew, cl-callf.
268 Use new cl-deftype-satisfies. Adjust to use of hashtables.
269 Don't hardcode the value of eieio--object-num-slots.
270 (eieio-defgeneric-form-primary-only-one): Remove `doc-string' arg.
271 Use a closure rather than a backquoted lambda.
272 (eieio--defmethod): Adjust call accordingly. Set doc-string via the
273 function-documentation property.
274 (eieio-slot-originating-class-p, eieio-slot-name-index)
275 (eieiomt--optimizing-hashtable, eieiomt-install, eieiomt-add)
276 (eieio-generic-form): Adjust to use of hashtables.
277 (eieiomt--sym-optimize): Rename from eieiomt-sym-optimize; take
278 additional class argument.
279 (eieio-generic-call-methodname): Remove, unused.
280
281 * emacs-lisp/eieio-base.el (eieio-persistent-slot-type-is-class-p):
282 Prefer \' to $.
283
2842015-01-08 Eli Zaretskii <eliz@gnu.org>
285
286 * simple.el (line-move-visual): When converting X pixel coordinate
287 to temporary-goal-column, adjust the value for right-to-left
288 screen lines. This fixes vertical-motion, next/prev-line, etc.
289
2902015-01-08 Glenn Morris <rgm@gnu.org>
291
292 * files.el (file-tree-walk): Remove; of unknown authorship. (Bug#19325)
293
2942015-01-07 K. Handa <handa@gnu.org>
295
296 * international/ccl.el (define-ccl-program): Improve the docstring.
297
2982015-01-06 Sam Steingold <sds@gnu.org>
299
300 * shell.el (shell-display-buffer-actions): Remove,
301 use `display-buffer-alist' instead.
302
3032015-01-05 Dmitry Gutov <dgutov@yandex.ru>
304
305 * progmodes/xref.el (xref--insert-xrefs): Add `help-echo' property
306 to the references.
307
3082015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
309
310 * minibuffer.el (completion-category-defaults): New var.
311 Set unicode-name to use substring completion.
312 (completion-category-defaults): Set it to nil.
313
12015-01-04 Dmitry Gutov <dgutov@yandex.ru> 3142015-01-04 Dmitry Gutov <dgutov@yandex.ru>
2 315
3 Add mouse interaction to xref. 316 Add mouse interaction to xref.
4
5 * progmodes/xref.el (xref--button-map): New variable. 317 * progmodes/xref.el (xref--button-map): New variable.
6 (xref--mouse-2): New command. 318 (xref--mouse-2): New command.
7 (xref--insert-xrefs): Add `mouse-face' and `keymap' properties to 319 (xref--insert-xrefs): Add `mouse-face' and `keymap' properties to
@@ -30,7 +342,6 @@
302015-01-04 Dmitry Gutov <dgutov@yandex.ru> 3422015-01-04 Dmitry Gutov <dgutov@yandex.ru>
31 343
32 Unbreak `mouse-action' property in text buttons. 344 Unbreak `mouse-action' property in text buttons.
33
34 * button.el (push-button): Fix regression from 2012-12-06. 345 * button.el (push-button): Fix regression from 2012-12-06.
35 346
362015-01-03 Dmitry Gutov <dgutov@yandex.ru> 3472015-01-03 Dmitry Gutov <dgutov@yandex.ru>
@@ -144,11 +455,9 @@
1442014-12-29 Dmitry Gutov <dgutov@yandex.ru> 4552014-12-29 Dmitry Gutov <dgutov@yandex.ru>
145 456
146 Unbreak jumping to an alias's definition. 457 Unbreak jumping to an alias's definition.
147
148 * emacs-lisp/find-func.el (find-function-library): Return a pair 458 * emacs-lisp/find-func.el (find-function-library): Return a pair
149 (ORIG-FUNCTION . LIBRARY) instead of just its second element. 459 (ORIG-FUNCTION . LIBRARY) instead of just its second element.
150 (find-function-noselect): Use it. 460 (find-function-noselect): Use it.
151
152 * progmodes/elisp-mode.el (elisp--xref-identifier-file): Rename to 461 * progmodes/elisp-mode.el (elisp--xref-identifier-file): Rename to
153 `elisp--xref-identifier-location', incorporate logic from 462 `elisp--xref-identifier-location', incorporate logic from
154 `elisp--xref-find-definitions', use the changed 463 `elisp--xref-find-definitions', use the changed
@@ -217,7 +526,6 @@
2172014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> 5262014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
218 527
219 python.el: Native readline completion. 528 python.el: Native readline completion.
220
221 * progmodes/python.el (python-shell-completion-native-disabled-interpreters) 529 * progmodes/python.el (python-shell-completion-native-disabled-interpreters)
222 (python-shell-completion-native-enable) 530 (python-shell-completion-native-enable)
223 (python-shell-completion-native-output-timeout): New defcustoms. 531 (python-shell-completion-native-output-timeout): New defcustoms.
@@ -236,9 +544,8 @@
236 544
237 python.el: Enhance shell user interaction and deprecate 545 python.el: Enhance shell user interaction and deprecate
238 python-shell-get-or-create-process. 546 python-shell-get-or-create-process.
239 547 * progmodes/python.el (python-shell-get-process-or-error):
240 * progmodes/python.el 548 New function.
241 (python-shell-get-process-or-error): New function.
242 (python-shell-with-shell-buffer): Use it. 549 (python-shell-with-shell-buffer): Use it.
243 (python-shell-send-string, python-shell-send-region) 550 (python-shell-send-string, python-shell-send-region)
244 (python-shell-send-buffer, python-shell-send-defun) 551 (python-shell-send-buffer, python-shell-send-defun)
@@ -266,22 +573,15 @@
2662014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> 5732014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
267 574
268 python.el: Fix message when sending region. 575 python.el: Fix message when sending region.
269
270 * progmodes/python.el (python-shell-send-region): Rename argument 576 * progmodes/python.el (python-shell-send-region): Rename argument
271 send-main from nomain. Fix message. 577 send-main from nomain. Fix message.
272 (python-shell-send-buffer): Rename argument send-main from arg. 578 (python-shell-send-buffer): Rename argument send-main from arg.
273 579
2742014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
275
276 python.el: Cleanup temp files even with eval errors. 580 python.el: Cleanup temp files even with eval errors.
277
278 * progmodes/python.el (python-shell-send-file): Make file-name 581 * progmodes/python.el (python-shell-send-file): Make file-name
279 mandatory. Fix temp file removal in the majority of cases. 582 mandatory. Fix temp file removal in the majority of cases.
280 583
2812014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
282
283 python.el: Handle file encoding for shell. 584 python.el: Handle file encoding for shell.
284
285 * progmodes/python.el (python-rx-constituents): Add coding-cookie. 585 * progmodes/python.el (python-rx-constituents): Add coding-cookie.
286 (python-shell--save-temp-file): Write file with proper encoding. 586 (python-shell--save-temp-file): Write file with proper encoding.
287 (python-shell-buffer-substring): Add coding cookie for detected 587 (python-shell-buffer-substring): Add coding cookie for detected
@@ -343,7 +643,7 @@
343 643
3442014-12-27 Stefan Monnier <monnier@iro.umontreal.ca> 6442014-12-27 Stefan Monnier <monnier@iro.umontreal.ca>
345 645
346 * lisp/subr.el (redisplay-dont-pause): Mark as obsolete. 646 * subr.el (redisplay-dont-pause): Mark as obsolete.
347 647
3482014-12-27 Michael Albinus <michael.albinus@gmx.de> 6482014-12-27 Michael Albinus <michael.albinus@gmx.de>
349 649
@@ -416,7 +716,6 @@
4162014-12-26 Fabián Ezequiel Gallina <fgallina@gnu.org> 7162014-12-26 Fabián Ezequiel Gallina <fgallina@gnu.org>
417 717
418 python.el: Generate clearer shell buffer names. 718 python.el: Generate clearer shell buffer names.
419
420 * progmodes/python.el (python-shell-get-process-name) 719 * progmodes/python.el (python-shell-get-process-name)
421 (python-shell-internal-get-process-name): Use `buffer-name`. 720 (python-shell-internal-get-process-name): Use `buffer-name`.
422 (python-shell-internal-get-or-create-process): Simplify. 721 (python-shell-internal-get-or-create-process): Simplify.
@@ -539,7 +838,7 @@
5392014-12-19 Alan Mackenzie <acm@muc.de> 8382014-12-19 Alan Mackenzie <acm@muc.de>
540 839
541 Make C++11 uniform init syntax work. 840 Make C++11 uniform init syntax work.
542 New keywords "final" and "override" 841 New keywords "final" and "override".
543 * progmodes/cc-engine.el (c-back-over-member-initializer-braces): 842 * progmodes/cc-engine.el (c-back-over-member-initializer-braces):
544 New function. 843 New function.
545 (c-guess-basic-syntax): Set `containing-sex' and `lim' using the 844 (c-guess-basic-syntax): Set `containing-sex' and `lim' using the
@@ -575,8 +874,7 @@
575 874
5762014-12-18 Artur Malabarba <bruce.connor.am@gmail.com> 8752014-12-18 Artur Malabarba <bruce.connor.am@gmail.com>
577 876
578 * let-alist.el (let-alist): Evaluate the `alist' argument only 877 * let-alist.el (let-alist): Evaluate the `alist' argument only once.
579 once.
580 878
5812014-12-18 Sam Steingold <sds@gnu.org> 8792014-12-18 Sam Steingold <sds@gnu.org>
582 880
@@ -590,13 +888,12 @@
590 Add code for "preserving" window sizes. 888 Add code for "preserving" window sizes.
591 * dired.el (dired-pop-to-buffer): Call fit-window-to-buffer with 889 * dired.el (dired-pop-to-buffer): Call fit-window-to-buffer with
592 `preserve-size' t. 890 `preserve-size' t.
593 (dired-mark-pop-up): Preserve size of window showing marked 891 (dired-mark-pop-up): Preserve size of window showing marked files.
594 files.
595 * electric.el (Electric-pop-up-window): 892 * electric.el (Electric-pop-up-window):
596 * help.el (resize-temp-buffer-window): Call fit-window-to-buffer 893 * help.el (resize-temp-buffer-window): Call fit-window-to-buffer
597 with `preserve-size' t. 894 with `preserve-size' t.
598 * minibuffer.el (minibuffer-completion-help): Use 895 * minibuffer.el (minibuffer-completion-help):
599 `resize-temp-buffer-window' instead of `fit-window-to-buffer' 896 Use `resize-temp-buffer-window' instead of `fit-window-to-buffer'
600 (Bug#19355). Preserve size of completions window. 897 (Bug#19355). Preserve size of completions window.
601 * register.el (register-preview): Preserve size of register 898 * register.el (register-preview): Preserve size of register
602 preview window. 899 preview window.
@@ -606,8 +903,7 @@
606 `window-preserve-size'. 903 `window-preserve-size'.
607 (window-min-pixel-size, window--preservable-size) 904 (window-min-pixel-size, window--preservable-size)
608 (window-preserve-size, window-preserved-size) 905 (window-preserve-size, window-preserved-size)
609 (window--preserve-size, window--min-size-ignore-p): New 906 (window--preserve-size, window--min-size-ignore-p): New functions.
610 functions.
611 (window-min-size, window-min-delta, window--resizable) 907 (window-min-size, window-min-delta, window--resizable)
612 (window--resize-this-window, split-window-below) 908 (window--resize-this-window, split-window-below)
613 (split-window-right): Amend doc-string. 909 (split-window-right): Amend doc-string.
@@ -622,8 +918,7 @@
622 window above or below. 918 window above or below.
623 (window--state-put-2): Handle horizontal scroll bars. 919 (window--state-put-2): Handle horizontal scroll bars.
624 (window--display-buffer): Call `preserve-size' if asked for. 920 (window--display-buffer): Call `preserve-size' if asked for.
625 (display-buffer): Mention `preserve-size' alist member in 921 (display-buffer): Mention `preserve-size' alist member in doc-string.
626 doc-string.
627 (fit-window-to-buffer): New argument PRESERVE-SIZE. 922 (fit-window-to-buffer): New argument PRESERVE-SIZE.
628 * textmodes/ispell.el (ispell-command-loop): Suppress horizontal 923 * textmodes/ispell.el (ispell-command-loop): Suppress horizontal
629 scroll bar on ispell's windows. Don't count window lines and 924 scroll bar on ispell's windows. Don't count window lines and
@@ -711,7 +1006,7 @@
711 1006
7122014-12-14 Alan Mackenzie <acm@muc.de> 10072014-12-14 Alan Mackenzie <acm@muc.de>
713 1008
714 * lisp/cus-start.el (all): Add fast-but-imprecise-scrolling. 1009 * cus-start.el (all): Add fast-but-imprecise-scrolling.
715 1010
7162014-12-14 Artur Malabarba <bruce.connor.am@gmail.com> 10112014-12-14 Artur Malabarba <bruce.connor.am@gmail.com>
717 1012
@@ -1857,7 +2152,7 @@
1857 2152
18582014-11-19 Artur Malabarba <bruce.connor.am@gmail.com> 21532014-11-19 Artur Malabarba <bruce.connor.am@gmail.com>
1859 2154
1860 * lisp/ido.el (ido-bury-buffer-at-head): New command. 2155 * ido.el (ido-bury-buffer-at-head): New command.
1861 (ido-buffer-completion-map): Bind it to C-S-b. 2156 (ido-buffer-completion-map): Bind it to C-S-b.
1862 2157
18632014-11-18 Juri Linkov <juri@linkov.net> 21582014-11-18 Juri Linkov <juri@linkov.net>
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/files.el b/lisp/files.el
index 80b538c3267..1533c35e6ca 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -729,38 +729,6 @@ The path separator is colon in GNU and GNU-like systems."
729 (lambda (f) (and (file-directory-p f) 'dir-ok))) 729 (lambda (f) (and (file-directory-p f) 'dir-ok)))
730 (error "No such directory found via CDPATH environment variable")))) 730 (error "No such directory found via CDPATH environment variable"))))
731 731
732(defun file-tree-walk (dir action &rest args)
733 "Walk DIR executing ACTION on each file, with ARGS as additional arguments.
734For each file, the function calls ACTION as follows:
735
736 \(ACTION DIRECTORY BASENAME ARGS\)
737
738Where DIRECTORY is the leading directory of the file,
739 BASENAME is the basename of the file,
740 and ARGS are as specified in the call to this function, or nil if omitted.
741
742The ACTION is applied to each subdirectory before descending into
743it, and if nil is returned at that point, the descent will be
744prevented. Directory entries are sorted with string-lessp."
745 (cond ((file-directory-p dir)
746 (setq dir (file-name-as-directory dir))
747 (let ((lst (directory-files dir nil nil t))
748 fullname file)
749 (while lst
750 (setq file (car lst))
751 (setq lst (cdr lst))
752 (cond ((member file '("." "..")))
753 (t
754 (and (apply action dir file args)
755 (setq fullname (concat dir file))
756 (file-directory-p fullname)
757 (apply 'file-tree-walk fullname action args)))))))
758 (t
759 (apply action
760 (file-name-directory dir)
761 (file-name-nondirectory dir)
762 args))))
763
764(defsubst directory-name-p (name) 732(defsubst directory-name-p (name)
765 "Return non-nil if NAME ends with a slash character." 733 "Return non-nil if NAME ends with a slash character."
766 (and (> (length name) 0) 734 (and (> (length name) 0)
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 73a0de76a1f..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):
@@ -10,6 +14,12 @@
10 * mm-decode.el (mm-shr): Bind `shr-width' to `fill-column' so that 14 * mm-decode.el (mm-shr): Bind `shr-width' to `fill-column' so that
11 lines don't get overlong when responding. 15 lines don't get overlong when responding.
12 16
172014-12-19 Andreas Schwab <schwab@linux-m68k.org>
18
19 * gnus-group.el (gnus-read-ephemeral-bug-group):
20 Bind coding-system-for-read and coding-system-for-write only around
21 with-temp-file, and make buffer unibyte. Don't write temp file twice.
22
132014-12-18 Paul Eggert <eggert@cs.ucla.edu> 232014-12-18 Paul Eggert <eggert@cs.ucla.edu>
14 24
15 * registry.el (registry-db): Set default slot later. 25 * registry.el (registry-db): Set default slot later.
@@ -67,9 +77,9 @@
67 77
682014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org> 782014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
69 79
70 * gnus-art.el (gnus-article-mime-handles): Refactored out into own 80 * gnus-art.el (gnus-article-mime-handles): Refactor out into own
71 function for reuse. 81 function for reuse.
72 (gnus-mime-buttonize-attachments-in-header): Adjusted. 82 (gnus-mime-buttonize-attachments-in-header): Adjust.
73 83
742014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org> 842014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
75 85
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 29c380f8234..f3dcc40b8c4 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -2455,27 +2455,27 @@ the bug number, and browsing the URL must return mbox output."
2455 (setq ids (string-to-number ids))) 2455 (setq ids (string-to-number ids)))
2456 (unless (listp ids) 2456 (unless (listp ids)
2457 (setq ids (list ids))) 2457 (setq ids (list ids)))
2458 (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")) 2458 (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
2459 (coding-system-for-write 'binary) 2459 (let ((coding-system-for-write 'binary)
2460 (coding-system-for-read 'binary)) 2460 (coding-system-for-read 'binary))
2461 (with-temp-file tmpfile 2461 (with-temp-file tmpfile
2462 (dolist (id ids) 2462 (mm-disable-multibyte)
2463 (url-insert-file-contents (format mbox-url id))) 2463 (dolist (id ids)
2464 (goto-char (point-min)) 2464 (url-insert-file-contents (format mbox-url id)))
2465 ;; Add the debbugs address so that we can respond to reports easily. 2465 (goto-char (point-min))
2466 (while (re-search-forward "^To: " nil t) 2466 ;; Add the debbugs address so that we can respond to reports easily.
2467 (end-of-line) 2467 (while (re-search-forward "^To: " nil t)
2468 (insert (format ", %s@%s" (car ids) 2468 (end-of-line)
2469 (gnus-replace-in-string 2469 (insert (format ", %s@%s" (car ids)
2470 (gnus-replace-in-string mbox-url "^http://" "") 2470 (gnus-replace-in-string
2471 "/.*$" "")))) 2471 (gnus-replace-in-string mbox-url "^http://" "")
2472 (write-region (point-min) (point-max) tmpfile) 2472 "/.*$" ""))))))
2473 (gnus-group-read-ephemeral-group 2473 (gnus-group-read-ephemeral-group
2474 (format "nndoc+ephemeral:bug#%s" 2474 (format "nndoc+ephemeral:bug#%s"
2475 (mapconcat 'number-to-string ids ",")) 2475 (mapconcat 'number-to-string ids ","))
2476 `(nndoc ,tmpfile 2476 `(nndoc ,tmpfile
2477 (nndoc-article-type mbox)) 2477 (nndoc-article-type mbox))
2478 nil window-conf)) 2478 nil window-conf)
2479 (delete-file tmpfile))) 2479 (delete-file tmpfile)))
2480 2480
2481(defun gnus-read-ephemeral-debian-bug-group (number) 2481(defun gnus-read-ephemeral-debian-bug-group (number)
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/lisp/international/ccl.el b/lisp/international/ccl.el
index 9eb091f80c1..429c14b5e44 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -1355,6 +1355,14 @@ IF := (if EXPRESSION CCL_BLOCK_0 CCL_BLOCK_1)
1355BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...]) 1355BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...])
1356 1356
1357;; Execute STATEMENTs until (break) or (end) is executed. 1357;; Execute STATEMENTs until (break) or (end) is executed.
1358
1359;; Create a block of STATEMENTs for repeating. The STATEMENTs
1360;; are executed sequentially until REPEAT or BREAK is executed.
1361;; If REPEAT statement is executed, STATEMENTs are executed from the
1362;; start again. If BREAK statements is executed, the execution
1363;; exits from the block. If neither REPEAT nor BREAK is
1364;; executed, the execution exits from the block after executing the
1365;; last STATEMENT.
1358LOOP := (loop STATEMENT [STATEMENT ...]) 1366LOOP := (loop STATEMENT [STATEMENT ...])
1359 1367
1360;; Terminate the most inner loop. 1368;; Terminate the most inner loop.
@@ -1501,17 +1509,42 @@ ARRAY := `[' integer ... `]'
1501 1509
1502 1510
1503TRANSLATE := 1511TRANSLATE :=
1504 (translate-character REG(table) REG(charset) REG(codepoint)) 1512 ;; Decode character SRC, translate it by translate table
1505 | (translate-character SYMBOL REG(charset) REG(codepoint)) 1513 ;; TABLE, and encode it back to DST. TABLE is specified
1506 ;; SYMBOL must refer to a table defined by `define-translation-table'. 1514 ;; by its id number in REG_0, SRC is specified by its
1515 ;; charset id number and codepoint in REG_1 and REG_2
1516 ;; respectively.
1517 ;; On encoding, the charset of highest priority is selected.
1518 ;; After the execution, DST is specified by its charset
1519 ;; id number and codepoint in REG_1 and REG_2 respectively.
1520 (translate-character REG_0 REG_1 REG_2)
1521
1522 ;; Same as above except for SYMBOL specifying the name of
1523 ;; the translate table defined by `define-translation-table'.
1524 | (translate-character SYMBOL REG_1 REG_2)
1525
1507LOOKUP := 1526LOOKUP :=
1508 (lookup-character SYMBOL REG(charset) REG(codepoint)) 1527 ;; Look up character SRC in hash table TABLE. TABLE is
1528 ;; specified by its name in SYMBOL, and SRC is specified by
1529 ;; its charset id number and codepoint in REG_1 and REG_2
1530 ;; respectively.
1531 ;; If its associated value is an integer, set REG_1 to that
1532 ;; value, and set r7 to 1. Otherwise, set r7 to 0.
1533 (lookup-character SYMBOL REG_1 REG_2)
1534
1535 ;; Look up integer value N in hash table TABLE. TABLE is
1536 ;; specified by its name in SYMBOL and N is specified in
1537 ;; REG.
1538 ;; If its associated value is a character, set REG to that
1539 ;; value, and set r7 to 1. Otherwise, set r7 to 0.
1509 | (lookup-integer SYMBOL REG(integer)) 1540 | (lookup-integer SYMBOL REG(integer))
1510 ;; SYMBOL refers to a table defined by `define-translation-hash-table'. 1541
1511MAP := 1542MAP :=
1512 (iterate-multiple-map REG REG MAP-IDs) 1543 ;; The following statements are for internal use only.
1513 | (map-multiple REG REG (MAP-SET)) 1544 (iterate-multiple-map REG REG MAP-IDs)
1514 | (map-single REG REG MAP-ID) 1545 | (map-multiple REG REG (MAP-SET))
1546 | (map-single REG REG MAP-ID)
1547
1515MAP-IDs := MAP-ID ... 1548MAP-IDs := MAP-ID ...
1516MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET 1549MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET
1517MAP-ID := integer 1550MAP-ID := integer
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 16312444e3c..538bd974256 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -826,16 +826,27 @@ styles for specific categories, such as files, buffers, etc."
826 :type completion--styles-type 826 :type completion--styles-type
827 :version "23.1") 827 :version "23.1")
828 828
829(defcustom completion-category-overrides 829(defvar completion-category-defaults
830 '((buffer (styles . (basic substring)))) 830 '((buffer (styles . (basic substring)))
831 "List of `completion-styles' overrides for specific categories. 831 (unicode-name (styles . (basic substring))))
832 "Default settings for specific completion categories.
833Each entry has the shape (CATEGORY . ALIST) where ALIST is
834an association list that can specify properties such as:
835- `styles': the list of `completion-styles' to use for that category.
836- `cycle': the `completion-cycle-threshold' to use for that category.
837Categories are symbols such as `buffer' and `file', used when
838completing buffer and file names, respectively.")
839
840(defcustom completion-category-overrides nil
841 "List of category-specific user overrides for completion styles.
832Each override has the shape (CATEGORY . ALIST) where ALIST is 842Each override has the shape (CATEGORY . ALIST) where ALIST is
833an association list that can specify properties such as: 843an association list that can specify properties such as:
834- `styles': the list of `completion-styles' to use for that category. 844- `styles': the list of `completion-styles' to use for that category.
835- `cycle': the `completion-cycle-threshold' to use for that category. 845- `cycle': the `completion-cycle-threshold' to use for that category.
836Categories are symbols such as `buffer' and `file', used when 846Categories are symbols such as `buffer' and `file', used when
837completing buffer and file names, respectively." 847completing buffer and file names, respectively.
838 :version "24.1" 848This overrides the defaults specified in `completion-category-defaults'."
849 :version "25.1"
839 :type `(alist :key-type (choice :tag "Category" 850 :type `(alist :key-type (choice :tag "Category"
840 (const buffer) 851 (const buffer)
841 (const file) 852 (const file)
@@ -851,9 +862,13 @@ completing buffer and file names, respectively."
851 (const :tag "Select one value from the menu." cycle) 862 (const :tag "Select one value from the menu." cycle)
852 ,completion--cycling-threshold-type)))) 863 ,completion--cycling-threshold-type))))
853 864
865(defun completion--category-override (category tag)
866 (or (assq tag (cdr (assq category completion-category-overrides)))
867 (assq tag (cdr (assq category completion-category-defaults)))))
868
854(defun completion--styles (metadata) 869(defun completion--styles (metadata)
855 (let* ((cat (completion-metadata-get metadata 'category)) 870 (let* ((cat (completion-metadata-get metadata 'category))
856 (over (assq 'styles (cdr (assq cat completion-category-overrides))))) 871 (over (completion--category-override cat 'styles)))
857 (if over 872 (if over
858 (delete-dups (append (cdr over) (copy-sequence completion-styles))) 873 (delete-dups (append (cdr over) (copy-sequence completion-styles)))
859 completion-styles))) 874 completion-styles)))
@@ -967,7 +982,7 @@ completion candidates than this number."
967 982
968(defun completion--cycle-threshold (metadata) 983(defun completion--cycle-threshold (metadata)
969 (let* ((cat (completion-metadata-get metadata 'category)) 984 (let* ((cat (completion-metadata-get metadata 'category))
970 (over (assq 'cycle (cdr (assq cat completion-category-overrides))))) 985 (over (completion--category-override cat 'cycle)))
971 (if over (cdr over) completion-cycle-threshold))) 986 (if over (cdr over) completion-cycle-threshold)))
972 987
973(defvar-local completion-all-sorted-completions nil) 988(defvar-local completion-all-sorted-completions nil)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 2ce95d97ff8..6a6da17d1ce 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -255,14 +255,18 @@ word(s) will be searched for via `eww-search-prefix'."
255 ((string-match-p "\\`ftp://" url) 255 ((string-match-p "\\`ftp://" url)
256 (user-error "FTP is not supported.")) 256 (user-error "FTP is not supported."))
257 (t 257 (t
258 (if (and (= (length (split-string url)) 1) 258 (if (or (string-match "\\`https?:" url)
259 (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url)) 259 ;; Also try to match "naked" URLs like
260 (> (length (split-string url "[.:]")) 1)) 260 ;; en.wikipedia.org/wiki/Free software
261 (string-match eww-local-regex url))) 261 (string-match "\\`[A-Za-z_]+\\.[A-Za-z._]+/" url)
262 (and (= (length (split-string url)) 1)
263 (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url))
264 (> (length (split-string url "[.:]")) 1))
265 (string-match eww-local-regex url))))
262 (progn 266 (progn
263 (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url) 267 (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
264 (setq url (concat "http://" url))) 268 (setq url (concat "http://" url)))
265 ;; some site don't redirect final / 269 ;; Some sites do not redirect final /
266 (when (string= (url-filename (url-generic-parse-url url)) "") 270 (when (string= (url-filename (url-generic-parse-url url)) "")
267 (setq url (concat url "/")))) 271 (setq url (concat url "/"))))
268 (setq url (concat eww-search-prefix 272 (setq url (concat eww-search-prefix
@@ -273,6 +277,7 @@ word(s) will be searched for via `eww-search-prefix'."
273 (eww-save-history)) 277 (eww-save-history))
274 (eww-setup-buffer) 278 (eww-setup-buffer)
275 (plist-put eww-data :url url) 279 (plist-put eww-data :url url)
280 (plist-put eww-data :title "")
276 (eww-update-header-line-format) 281 (eww-update-header-line-format)
277 (let ((inhibit-read-only t)) 282 (let ((inhibit-read-only t))
278 (insert (format "Loading %s..." url)) 283 (insert (format "Loading %s..." url))
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index ed824cf3fb2..feb934c7190 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -894,7 +894,12 @@ START, and END. Note that START and END should be markers."
894 (add-text-properties 894 (add-text-properties
895 start (point) 895 start (point)
896 (list 'shr-url url 896 (list 'shr-url url
897 'help-echo (if title (shr-fold-text (format "%s (%s)" url title)) url) 897 'help-echo (let ((iri (or (ignore-errors
898 (decode-coding-string
899 (url-unhex-string url)
900 'utf-8 t))
901 url)))
902 (if title (format "%s (%s)" iri title) iri))
898 'follow-link t 903 'follow-link t
899 'mouse-face 'highlight 904 'mouse-face 'highlight
900 'keymap shr-map))) 905 'keymap shr-map)))
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index de6a33988a4..c25e52cdc6a 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -248,7 +248,7 @@ name as matched contains
248 248
249(defconst js--function-heading-1-re 249(defconst js--function-heading-1-re
250 (concat 250 (concat
251 "^\\s-*function\\s-+\\(" js--name-re "\\)") 251 "^\\s-*function\\(?:\\s-\\|\\*\\)+\\(" js--name-re "\\)")
252 "Regexp matching the start of a JavaScript function header. 252 "Regexp matching the start of a JavaScript function header.
253Match group 1 is the name of the function.") 253Match group 1 is the name of the function.")
254 254
@@ -796,6 +796,9 @@ determined. Otherwise, return nil."
796 (let ((name t)) 796 (let ((name t))
797 (forward-word) 797 (forward-word)
798 (forward-comment most-positive-fixnum) 798 (forward-comment most-positive-fixnum)
799 (when (eq (char-after) ?*)
800 (forward-char)
801 (forward-comment most-positive-fixnum))
799 (when (looking-at js--name-re) 802 (when (looking-at js--name-re)
800 (setq name (match-string-no-properties 0)) 803 (setq name (match-string-no-properties 0))
801 (goto-char (match-end 0))) 804 (goto-char (match-end 0)))
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 41b70c7eff2..b822619f783 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -434,7 +434,8 @@ GROUP is a string for decoration purposes and XREF is an
434 (list 'xref-location location 434 (list 'xref-location location
435 'face 'font-lock-keyword-face 435 'face 'font-lock-keyword-face
436 'mouse-face 'highlight 436 'mouse-face 'highlight
437 'keymap xref--button-map) 437 'keymap xref--button-map
438 'help-echo "mouse-2: display, RET or mouse-1: navigate")
438 description)) 439 description))
439 (when (or more1 more2) 440 (when (or more1 more2)
440 (insert "\n"))))) 441 (insert "\n")))))
diff --git a/lisp/shell.el b/lisp/shell.el
index 6e336eb1403..f71d1407a49 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -309,13 +309,6 @@ for Shell mode only."
309 (const :tag "on" t)) 309 (const :tag "on" t))
310 :group 'shell) 310 :group 'shell)
311 311
312(defcustom shell-display-buffer-actions display-buffer-base-action
313 "The `display-buffer' actions for the `*shell*' buffer."
314 :type display-buffer--action-custom-type
315 :risky t
316 :version "25.1"
317 :group 'shell)
318
319(defvar shell-dirstack nil 312(defvar shell-dirstack nil
320 "List of directories saved by pushd in this buffer's shell. 313 "List of directories saved by pushd in this buffer's shell.
321Thus, this does not include the shell's current directory.") 314Thus, this does not include the shell's current directory.")
@@ -726,7 +719,7 @@ Otherwise, one argument `-i' is passed to the shell.
726 719
727 ;; The buffer's window must be correctly set when we call comint (so 720 ;; The buffer's window must be correctly set when we call comint (so
728 ;; that comint sets the COLUMNS env var properly). 721 ;; that comint sets the COLUMNS env var properly).
729 (pop-to-buffer buffer shell-display-buffer-actions) 722 (pop-to-buffer buffer)
730 (unless (comint-check-proc buffer) 723 (unless (comint-check-proc buffer)
731 (let* ((prog (or explicit-shell-file-name 724 (let* ((prog (or explicit-shell-file-name
732 (getenv "ESHELL") shell-file-name)) 725 (getenv "ESHELL") shell-file-name))
diff --git a/lisp/simple.el b/lisp/simple.el
index e15291a345b..25293edf88f 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -5604,14 +5604,22 @@ If NOERROR, don't signal an error if we can't move that many lines."
5604 (> (cdr temporary-goal-column) 0)) 5604 (> (cdr temporary-goal-column) 0))
5605 (setq target-hscroll (cdr temporary-goal-column))) 5605 (setq target-hscroll (cdr temporary-goal-column)))
5606 ;; Otherwise, we should reset `temporary-goal-column'. 5606 ;; Otherwise, we should reset `temporary-goal-column'.
5607 (let ((posn (posn-at-point))) 5607 (let ((posn (posn-at-point))
5608 x-pos)
5608 (cond 5609 (cond
5609 ;; Handle the `overflow-newline-into-fringe' case: 5610 ;; Handle the `overflow-newline-into-fringe' case:
5610 ((eq (nth 1 posn) 'right-fringe) 5611 ((eq (nth 1 posn) 'right-fringe)
5611 (setq temporary-goal-column (cons (- (window-width) 1) hscroll))) 5612 (setq temporary-goal-column (cons (- (window-width) 1) hscroll)))
5612 ((car (posn-x-y posn)) 5613 ((car (posn-x-y posn))
5614 (setq x-pos (car (posn-x-y posn)))
5615 ;; In R2L lines, the X pixel coordinate is measured from the
5616 ;; left edge of the window, but columns are still counted
5617 ;; from the logical-order beginning of the line, i.e. from
5618 ;; the right edge in this case. We need to adjust for that.
5619 (if (eq (current-bidi-paragraph-direction) 'right-to-left)
5620 (setq x-pos (- (window-body-width nil t) 1 x-pos)))
5613 (setq temporary-goal-column 5621 (setq temporary-goal-column
5614 (cons (/ (float (car (posn-x-y posn))) 5622 (cons (/ (float x-pos)
5615 (frame-char-width)) 5623 (frame-char-width))
5616 hscroll)))))) 5624 hscroll))))))
5617 (if target-hscroll 5625 (if target-hscroll
diff --git a/lisp/subr.el b/lisp/subr.el
index 8237a5b8d22..05345853edc 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1312,6 +1312,7 @@ is converted into a string by expressing it in decimal."
1312(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") 1312(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1")
1313(make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1") 1313(make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1")
1314(make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1") 1314(make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1")
1315(make-obsolete-variable 'redisplay-dont-pause nil "24.5")
1315(make-obsolete 'window-redisplay-end-trigger nil "23.1") 1316(make-obsolete 'window-redisplay-end-trigger nil "23.1")
1316(make-obsolete 'set-window-redisplay-end-trigger nil "23.1") 1317(make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
1317 1318
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index 3b1f6c7103c..7801f4f8ed9 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -886,7 +886,7 @@ current, and kill the buffer that visits the link."
886 (define-key map "=" 'vc-diff) 886 (define-key map "=" 'vc-diff)
887 (define-key map "D" 'vc-root-diff) 887 (define-key map "D" 'vc-root-diff)
888 (define-key map "~" 'vc-revision-other-window) 888 (define-key map "~" 'vc-revision-other-window)
889 (define-key map "[delete]" 'vc-delete-file) 889 (define-key map "x" 'vc-delete-file)
890 map)) 890 map))
891(fset 'vc-prefix-map vc-prefix-map) 891(fset 'vc-prefix-map vc-prefix-map)
892(define-key ctl-x-map "v" 'vc-prefix-map) 892(define-key ctl-x-map "v" 'vc-prefix-map)