Commit | Line | Data |
---|---|---|
6dd12ef2 | 1 | ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects |
f6b1b0a8 | 2 | ;;; or maybe Eric's Implementation of Emacs Interpreted Objects |
6dd12ef2 | 3 | |
73b0cd50 | 4 | ;; Copyright (C) 1995-1996, 1998-2011 Free Software Foundation, Inc. |
6dd12ef2 | 5 | |
9ffe3f52 | 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
a2930e43 | 7 | ;; Version: 1.3 |
6dd12ef2 CY |
8 | ;; Keywords: OO, lisp |
9 | ||
10 | ;; This file is part of GNU Emacs. | |
11 | ||
12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
14 | ;; the Free Software Foundation, either version 3 of the License, or | |
15 | ;; (at your option) any later version. | |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | ||
25 | ;;; Commentary: | |
26 | ;; | |
27 | ;; EIEIO is a series of Lisp routines which implements a subset of | |
28 | ;; CLOS, the Common Lisp Object System. In addition, EIEIO also adds | |
29 | ;; a few new features which help it integrate more strongly with the | |
30 | ;; Emacs running environment. | |
31 | ;; | |
32 | ;; See eieio.texi for complete documentation on using this package. | |
a2930e43 EL |
33 | ;; |
34 | ;; Note: the implementation of the c3 algorithm is based on: | |
35 | ;; Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan | |
36 | ;; Retrieved from: | |
37 | ;; http://192.220.96.201/dylan/linearization-oopsla96.html | |
6dd12ef2 CY |
38 | |
39 | ;; There is funny stuff going on with typep and deftype. This | |
40 | ;; is the only way I seem to be able to make this stuff load properly. | |
41 | ||
42 | ;; @TODO - fix :initform to be a form, not a quoted value | |
43 | ;; @TODO - Prefix non-clos functions with `eieio-'. | |
44 | ||
45 | ;;; Code: | |
46 | ||
67868d26 | 47 | (eval-when-compile |
876c194c | 48 | (require 'cl)) |
6dd12ef2 | 49 | |
a2930e43 | 50 | (defvar eieio-version "1.3" |
6dd12ef2 CY |
51 | "Current version of EIEIO.") |
52 | ||
53 | (defun eieio-version () | |
54 | "Display the current version of EIEIO." | |
55 | (interactive) | |
56 | (message eieio-version)) | |
57 | ||
58 | (eval-and-compile | |
a8f316ca | 59 | ;; About the above. EIEIO must process its own code when it compiles |
6dd12ef2 CY |
60 | ;; itself, thus, by eval-and-compiling outselves, we solve the problem. |
61 | ||
62 | ;; Compatibility | |
63 | (if (fboundp 'compiled-function-arglist) | |
64 | ||
65 | ;; XEmacs can only access a compiled functions arglist like this: | |
66 | (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) | |
67 | ||
68 | ;; Emacs doesn't have this function, but since FUNC is a vector, we can just | |
69 | ;; grab the appropriate element. | |
70 | (defun eieio-compiled-function-arglist (func) | |
71 | "Return the argument list for the compiled function FUNC." | |
72 | (aref func 0)) | |
73 | ||
74 | ) | |
75 | ||
76 | \f | |
77 | ;;; | |
78 | ;; Variable declarations. | |
79 | ;; | |
80 | ||
81 | (defvar eieio-hook nil | |
82 | "*This hook is executed, then cleared each time `defclass' is called.") | |
83 | ||
84 | (defvar eieio-error-unsupported-class-tags nil | |
a2930e43 | 85 | "Non-nil to throw an error if an encountered tag is unsupported. |
6dd12ef2 CY |
86 | This may prevent classes from CLOS applications from being used with EIEIO |
87 | since EIEIO does not support all CLOS tags.") | |
88 | ||
89 | (defvar eieio-skip-typecheck nil | |
90 | "*If non-nil, skip all slot typechecking. | |
91 | Set this to t permanently if a program is functioning well to get a | |
92 | small speed increase. This variable is also used internally to handle | |
93 | default setting for optimization purposes.") | |
94 | ||
95 | (defvar eieio-optimize-primary-methods-flag t | |
96 | "Non-nil means to optimize the method dispatch on primary methods.") | |
97 | ||
98 | ;; State Variables | |
7200d79c | 99 | ;; FIXME: These two constants below should have an `eieio-' prefix added!! |
6dd12ef2 CY |
100 | (defvar this nil |
101 | "Inside a method, this variable is the object in question. | |
102 | DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. | |
103 | ||
104 | Note: Embedded methods are no longer supported. The variable THIS is | |
105 | still set for CLOS methods for the sake of routines like | |
a8f316ca | 106 | `call-next-method'.") |
6dd12ef2 CY |
107 | |
108 | (defvar scoped-class nil | |
109 | "This is set to a class when a method is running. | |
110 | This is so we know we are allowed to check private parts or how to | |
111 | execute a `call-next-method'. DO NOT SET THIS YOURSELF!") | |
112 | ||
113 | (defvar eieio-initializing-object nil | |
114 | "Set to non-nil while initializing an object.") | |
115 | ||
116 | (defconst eieio-unbound | |
117 | (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) | |
118 | eieio-unbound | |
119 | (make-symbol "unbound")) | |
120 | "Uninterned symbol representing an unbound slot in an object.") | |
121 | ||
122 | ;; This is a bootstrap for eieio-default-superclass so it has a value | |
123 | ;; while it is being built itself. | |
124 | (defvar eieio-default-superclass nil) | |
125 | ||
7200d79c | 126 | ;; FIXME: The constants below should have an `eieio-' prefix added!! |
6dd12ef2 CY |
127 | (defconst class-symbol 1 "Class's symbol (self-referencing.).") |
128 | (defconst class-parent 2 "Class parent slot.") | |
129 | (defconst class-children 3 "Class children class slot.") | |
130 | (defconst class-symbol-obarray 4 "Obarray permitting fast access to variable position indexes.") | |
131 | ;; @todo | |
132 | ;; the word "public" here is leftovers from the very first version. | |
133 | ;; Get rid of it! | |
134 | (defconst class-public-a 5 "Class attribute index.") | |
135 | (defconst class-public-d 6 "Class attribute defaults index.") | |
136 | (defconst class-public-doc 7 "Class documentation strings for attributes.") | |
137 | (defconst class-public-type 8 "Class type for a slot.") | |
138 | (defconst class-public-custom 9 "Class custom type for a slot.") | |
139 | (defconst class-public-custom-label 10 "Class custom group for a slot.") | |
140 | (defconst class-public-custom-group 11 "Class custom group for a slot.") | |
141 | (defconst class-public-printer 12 "Printer for a slot.") | |
142 | (defconst class-protection 13 "Class protection for a slot.") | |
143 | (defconst class-initarg-tuples 14 "Class initarg tuples list.") | |
144 | (defconst class-class-allocation-a 15 "Class allocated attributes.") | |
145 | (defconst class-class-allocation-doc 16 "Class allocated documentation.") | |
146 | (defconst class-class-allocation-type 17 "Class allocated value type.") | |
147 | (defconst class-class-allocation-custom 18 "Class allocated custom descriptor.") | |
148 | (defconst class-class-allocation-custom-label 19 "Class allocated custom descriptor.") | |
149 | (defconst class-class-allocation-custom-group 20 "Class allocated custom group.") | |
150 | (defconst class-class-allocation-printer 21 "Class allocated printer for a slot.") | |
151 | (defconst class-class-allocation-protection 22 "Class allocated protection list.") | |
152 | (defconst class-class-allocation-values 23 "Class allocated value vector.") | |
153 | (defconst class-default-object-cache 24 | |
154 | "Cache index of what a newly created object would look like. | |
155 | This will speed up instantiation time as only a `copy-sequence' will | |
156 | be needed, instead of looping over all the values and setting them | |
157 | from the default.") | |
158 | (defconst class-options 25 | |
159 | "Storage location of tagged class options. | |
160 | Stored outright without modifications or stripping.") | |
161 | ||
162 | (defconst class-num-slots 26 | |
163 | "Number of slots in the class definition object.") | |
164 | ||
165 | (defconst object-class 1 "Index in an object vector where the class is stored.") | |
166 | (defconst object-name 2 "Index in an object where the name is stored.") | |
167 | ||
168 | (defconst method-static 0 "Index into :static tag on a method.") | |
169 | (defconst method-before 1 "Index into :before tag on a method.") | |
170 | (defconst method-primary 2 "Index into :primary tag on a method.") | |
171 | (defconst method-after 3 "Index into :after tag on a method.") | |
172 | (defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") | |
173 | (defconst method-generic-before 4 "Index into generic :before tag on a method.") | |
174 | (defconst method-generic-primary 5 "Index into generic :primary tag on a method.") | |
175 | (defconst method-generic-after 6 "Index into generic :after tag on a method.") | |
176 | (defconst method-num-slots 7 "Number of indexes into a method's vector.") | |
177 | ||
a2930e43 EL |
178 | (defsubst eieio-specialized-key-to-generic-key (key) |
179 | "Convert a specialized KEY into a generic method key." | |
180 | (cond ((eq key method-static) 0) ;; don't convert | |
181 | ((< key method-num-lists) (+ key 3)) ;; The conversion | |
182 | (t key) ;; already generic.. maybe. | |
183 | )) | |
184 | ||
6dd12ef2 CY |
185 | \f |
186 | ;;; Important macros used in eieio. | |
187 | ;; | |
188 | (defmacro class-v (class) | |
189 | "Internal: Return the class vector from the CLASS symbol." | |
190 | ;; No check: If eieio gets this far, it's probably been checked already. | |
191 | `(get ,class 'eieio-class-definition)) | |
192 | ||
193 | (defmacro class-p (class) | |
194 | "Return t if CLASS is a valid class vector. | |
195 | CLASS is a symbol." | |
196 | ;; this new method is faster since it doesn't waste time checking lots of | |
197 | ;; things. | |
198 | `(condition-case nil | |
199 | (eq (aref (class-v ,class) 0) 'defclass) | |
200 | (error nil))) | |
201 | ||
202 | (defmacro eieio-object-p (obj) | |
203 | "Return non-nil if OBJ is an EIEIO object." | |
204 | `(condition-case nil | |
205 | (let ((tobj ,obj)) | |
206 | (and (eq (aref tobj 0) 'object) | |
207 | (class-p (aref tobj object-class)))) | |
208 | (error nil))) | |
209 | (defalias 'object-p 'eieio-object-p) | |
210 | ||
211 | (defmacro class-constructor (class) | |
212 | "Return the symbol representing the constructor of CLASS." | |
213 | `(aref (class-v ,class) class-symbol)) | |
214 | ||
215 | (defmacro generic-p (method) | |
216 | "Return t if symbol METHOD is a generic function. | |
a8f316ca JB |
217 | Only methods have the symbol `eieio-method-obarray' as a property |
218 | \(which contains a list of all bindings to that method type.)" | |
6dd12ef2 CY |
219 | `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) |
220 | ||
221 | (defun generic-primary-only-p (method) | |
222 | "Return t if symbol METHOD is a generic function with only primary methods. | |
223 | Only methods have the symbol `eieio-method-obarray' as a property (which | |
224 | contains a list of all bindings to that method type.) | |
225 | Methods with only primary implementations are executed in an optimized way." | |
226 | (and (generic-p method) | |
227 | (let ((M (get method 'eieio-method-tree))) | |
228 | (and (< 0 (length (aref M method-primary))) | |
229 | (not (aref M method-static)) | |
230 | (not (aref M method-before)) | |
231 | (not (aref M method-after)) | |
232 | (not (aref M method-generic-before)) | |
233 | (not (aref M method-generic-primary)) | |
234 | (not (aref M method-generic-after)))) | |
235 | )) | |
236 | ||
237 | (defun generic-primary-only-one-p (method) | |
238 | "Return t if symbol METHOD is a generic function with only primary methods. | |
239 | Only methods have the symbol `eieio-method-obarray' as a property (which | |
240 | contains a list of all bindings to that method type.) | |
241 | Methods with only primary implementations are executed in an optimized way." | |
242 | (and (generic-p method) | |
243 | (let ((M (get method 'eieio-method-tree))) | |
244 | (and (= 1 (length (aref M method-primary))) | |
245 | (not (aref M method-static)) | |
246 | (not (aref M method-before)) | |
247 | (not (aref M method-after)) | |
248 | (not (aref M method-generic-before)) | |
249 | (not (aref M method-generic-primary)) | |
250 | (not (aref M method-generic-after)))) | |
251 | )) | |
252 | ||
253 | (defmacro class-option-assoc (list option) | |
a2930e43 | 254 | "Return from LIST the found OPTION, or nil if it doesn't exist." |
6dd12ef2 CY |
255 | `(car-safe (cdr (memq ,option ,list)))) |
256 | ||
257 | (defmacro class-option (class option) | |
258 | "Return the value stored for CLASS' OPTION. | |
259 | Return nil if that option doesn't exist." | |
260 | `(class-option-assoc (aref (class-v ,class) class-options) ',option)) | |
261 | ||
262 | (defmacro class-abstract-p (class) | |
263 | "Return non-nil if CLASS is abstract. | |
264 | Abstract classes cannot be instantiated." | |
265 | `(class-option ,class :abstract)) | |
266 | ||
267 | (defmacro class-method-invocation-order (class) | |
268 | "Return the invocation order of CLASS. | |
269 | Abstract classes cannot be instantiated." | |
270 | `(or (class-option ,class :method-invocation-order) | |
271 | :breadth-first)) | |
272 | ||
273 | \f | |
274 | ;;; Defining a new class | |
275 | ;; | |
276 | (defmacro defclass (name superclass slots &rest options-and-doc) | |
277 | "Define NAME as a new class derived from SUPERCLASS with SLOTS. | |
278 | OPTIONS-AND-DOC is used as the class' options and base documentation. | |
279 | SUPERCLASS is a list of superclasses to inherit from, with SLOTS | |
280 | being the slots residing in that class definition. NOTE: Currently | |
281 | only one slot may exist in SUPERCLASS as multiple inheritance is not | |
282 | yet supported. Supported tags are: | |
283 | ||
a8f316ca JB |
284 | :initform - Initializing form. |
285 | :initarg - Tag used during initialization. | |
286 | :accessor - Tag used to create a function to access this slot. | |
287 | :allocation - Specify where the value is stored. | |
288 | Defaults to `:instance', but could also be `:class'. | |
289 | :writer - A function symbol which will `write' an object's slot. | |
290 | :reader - A function symbol which will `read' an object. | |
291 | :type - The type of data allowed in this slot (see `typep'). | |
6dd12ef2 CY |
292 | :documentation |
293 | - A string documenting use of this slot. | |
294 | ||
295 | The following are extensions on CLOS: | |
296 | :protection - Specify protection for this slot. | |
a8f316ca | 297 | Defaults to `:public'. Also use `:protected', or `:private'. |
6dd12ef2 CY |
298 | :custom - When customizing an object, the custom :type. Public only. |
299 | :label - A text string label used for a slot when customizing. | |
300 | :group - Name of a customization group this slot belongs in. | |
301 | :printer - A function to call to print the value of a slot. | |
302 | See `eieio-override-prin1' as an example. | |
303 | ||
304 | A class can also have optional options. These options happen in place | |
a8f316ca | 305 | of documentation (including a :documentation tag), in addition to |
6dd12ef2 CY |
306 | documentation, or not at all. Supported options are: |
307 | ||
308 | :documentation - The doc-string used for this class. | |
309 | ||
310 | Options added to EIEIO: | |
311 | ||
a8f316ca | 312 | :allow-nil-initform - Non-nil to skip typechecking of null initforms. |
6dd12ef2 CY |
313 | :custom-groups - List of custom group names. Organizes slots into |
314 | reasonable groups for customizations. | |
315 | :abstract - Non-nil to prevent instances of this class. | |
316 | If a string, use as an error string if someone does | |
317 | try to make an instance. | |
318 | :method-invocation-order | |
9ffe3f52 | 319 | - Control the method invocation order if there is |
6dd12ef2 CY |
320 | multiple inheritance. Valid values are: |
321 | :breadth-first - The default. | |
322 | :depth-first | |
323 | ||
324 | Options in CLOS not supported in EIEIO: | |
325 | ||
326 | :metaclass - Class to use in place of `standard-class' | |
327 | :default-initargs - Initargs to use when initializing new objects of | |
328 | this class. | |
329 | ||
a8f316ca JB |
330 | Due to the way class options are set up, you can add any tags you wish, |
331 | and reference them using the function `class-option'." | |
6dd12ef2 CY |
332 | ;; We must `eval-and-compile' this so that when we byte compile |
333 | ;; an eieio program, there is no need to load it ahead of time. | |
334 | ;; It also provides lots of nice debugging errors at compile time. | |
335 | `(eval-and-compile | |
336 | (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) | |
337 | ||
338 | (defvar eieio-defclass-autoload-map (make-vector 7 nil) | |
339 | "Symbol map of superclasses we find in autoloads.") | |
340 | ||
341 | ;; We autoload this because it's used in `make-autoload'. | |
342 | ;;;###autoload | |
343 | (defun eieio-defclass-autoload (cname superclasses filename doc) | |
344 | "Create autoload symbols for the EIEIO class CNAME. | |
9ffe3f52 | 345 | SUPERCLASSES are the superclasses that CNAME inherits from. |
6dd12ef2 CY |
346 | DOC is the docstring for CNAME. |
347 | This function creates a mock-class for CNAME and adds it into | |
348 | SUPERCLASSES as children. | |
349 | It creates an autoload function for CNAME's constructor." | |
350 | ;; Assume we've already debugged inputs. | |
351 | ||
352 | (let* ((oldc (when (class-p cname) (class-v cname))) | |
353 | (newc (make-vector class-num-slots nil)) | |
354 | ) | |
355 | (if oldc | |
356 | nil ;; Do nothing if we already have this class. | |
357 | ||
358 | ;; Create the class in NEWC, but don't fill anything else in. | |
359 | (aset newc 0 'defclass) | |
360 | (aset newc class-symbol cname) | |
361 | ||
362 | (let ((clear-parent nil)) | |
363 | ;; No parents? | |
364 | (when (not superclasses) | |
365 | (setq superclasses '(eieio-default-superclass) | |
366 | clear-parent t) | |
367 | ) | |
368 | ||
369 | ;; Hook our new class into the existing structures so we can | |
370 | ;; autoload it later. | |
371 | (dolist (SC superclasses) | |
372 | ||
373 | ||
374 | ;; TODO - If we create an autoload that is in the map, that | |
375 | ;; map needs to be cleared! | |
376 | ||
377 | ||
378 | ;; Does our parent exist? | |
379 | (if (not (class-p SC)) | |
380 | ||
381 | ;; Create a symbol for this parent, and then store this | |
382 | ;; parent on that symbol. | |
383 | (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) | |
384 | (if (not (boundp sym)) | |
385 | (set sym (list cname)) | |
386 | (add-to-list sym cname)) | |
387 | ) | |
388 | ||
389 | ;; We have a parent, save the child in there. | |
390 | (when (not (member cname (aref (class-v SC) class-children))) | |
391 | (aset (class-v SC) class-children | |
392 | (cons cname (aref (class-v SC) class-children))))) | |
393 | ||
394 | ;; save parent in child | |
395 | (aset newc class-parent (cons SC (aref newc class-parent))) | |
396 | ) | |
397 | ||
8350f087 | 398 | ;; turn this into a usable self-pointing symbol |
6dd12ef2 CY |
399 | (set cname cname) |
400 | ||
401 | ;; Store the new class vector definition into the symbol. We need to | |
402 | ;; do this first so that we can call defmethod for the accessor. | |
403 | ;; The vector will be updated by the following while loop and will not | |
404 | ;; need to be stored a second time. | |
405 | (put cname 'eieio-class-definition newc) | |
406 | ||
407 | ;; Clear the parent | |
408 | (if clear-parent (aset newc class-parent nil)) | |
409 | ||
410 | ;; Create an autoload on top of our constructor function. | |
411 | (autoload cname filename doc nil nil) | |
412 | (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) | |
413 | (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) | |
414 | ||
415 | )))) | |
416 | ||
417 | (defsubst eieio-class-un-autoload (cname) | |
a8f316ca | 418 | "If class CNAME is in an autoload state, load its file." |
6dd12ef2 CY |
419 | (when (eq (car-safe (symbol-function cname)) 'autoload) |
420 | (load-library (car (cdr (symbol-function cname)))))) | |
421 | ||
422 | (defun eieio-defclass (cname superclasses slots options-and-doc) | |
d1dc2cc2 | 423 | ;; FIXME: Most of this should be moved to the `defclass' macro. |
a8f316ca JB |
424 | "Define CNAME as a new subclass of SUPERCLASSES. |
425 | SLOTS are the slots residing in that class definition, and options or | |
426 | documentation OPTIONS-AND-DOC is the toplevel documentation for this class. | |
427 | See `defclass' for more information." | |
6dd12ef2 CY |
428 | ;; Run our eieio-hook each time, and clear it when we are done. |
429 | ;; This way people can add hooks safely if they want to modify eieio | |
430 | ;; or add definitions when eieio is loaded or something like that. | |
431 | (run-hooks 'eieio-hook) | |
432 | (setq eieio-hook nil) | |
433 | ||
434 | (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname))) | |
435 | (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp superclasses))) | |
436 | ||
437 | (let* ((pname (if superclasses superclasses nil)) | |
438 | (newc (make-vector class-num-slots nil)) | |
439 | (oldc (when (class-p cname) (class-v cname))) | |
440 | (groups nil) ;; list of groups id'd from slots | |
441 | (options nil) | |
442 | (clearparent nil)) | |
443 | ||
444 | (aset newc 0 'defclass) | |
445 | (aset newc class-symbol cname) | |
446 | ||
a8f316ca | 447 | ;; If this class already existed, and we are updating its structure, |
6dd12ef2 CY |
448 | ;; make sure we keep the old child list. This can cause bugs, but |
449 | ;; if no new slots are created, it also saves time, and prevents | |
450 | ;; method table breakage, particularly when the users is only | |
451 | ;; byte compiling an EIEIO file. | |
452 | (if oldc | |
453 | (aset newc class-children (aref oldc class-children)) | |
454 | ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. | |
455 | ;; This is like the above, but deals with autoloads nicely. | |
456 | (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) | |
457 | (when sym | |
458 | (condition-case nil | |
459 | (aset newc class-children (symbol-value sym)) | |
460 | (error nil)) | |
461 | (unintern (symbol-name cname) eieio-defclass-autoload-map) | |
462 | )) | |
463 | ) | |
464 | ||
465 | (cond ((and (stringp (car options-and-doc)) | |
466 | (/= 1 (% (length options-and-doc) 2))) | |
467 | (error "Too many arguments to `defclass'")) | |
468 | ((and (symbolp (car options-and-doc)) | |
469 | (/= 0 (% (length options-and-doc) 2))) | |
470 | (error "Too many arguments to `defclass'")) | |
471 | ) | |
472 | ||
473 | (setq options | |
474 | (if (stringp (car options-and-doc)) | |
475 | (cons :documentation options-and-doc) | |
476 | options-and-doc)) | |
477 | ||
478 | (if pname | |
479 | (progn | |
480 | (while pname | |
481 | (if (and (car pname) (symbolp (car pname))) | |
482 | (if (not (class-p (car pname))) | |
483 | ;; bad class | |
484 | (error "Given parent class %s is not a class" (car pname)) | |
485 | ;; good parent class... | |
486 | ;; save new child in parent | |
487 | (when (not (member cname (aref (class-v (car pname)) class-children))) | |
488 | (aset (class-v (car pname)) class-children | |
489 | (cons cname (aref (class-v (car pname)) class-children)))) | |
490 | ;; Get custom groups, and store them into our local copy. | |
491 | (mapc (lambda (g) (add-to-list 'groups g)) | |
492 | (class-option (car pname) :custom-groups)) | |
493 | ;; save parent in child | |
494 | (aset newc class-parent (cons (car pname) (aref newc class-parent)))) | |
495 | (error "Invalid parent class %s" pname)) | |
496 | (setq pname (cdr pname))) | |
497 | ;; Reverse the list of our parents so that they are prioritized in | |
498 | ;; the same order as specified in the code. | |
499 | (aset newc class-parent (nreverse (aref newc class-parent))) ) | |
500 | ;; If there is nothing to loop over, then inherit from the | |
501 | ;; default superclass. | |
502 | (unless (eq cname 'eieio-default-superclass) | |
503 | ;; adopt the default parent here, but clear it later... | |
504 | (setq clearparent t) | |
505 | ;; save new child in parent | |
506 | (if (not (member cname (aref (class-v 'eieio-default-superclass) class-children))) | |
507 | (aset (class-v 'eieio-default-superclass) class-children | |
508 | (cons cname (aref (class-v 'eieio-default-superclass) class-children)))) | |
509 | ;; save parent in child | |
510 | (aset newc class-parent (list eieio-default-superclass)))) | |
511 | ||
8350f087 | 512 | ;; turn this into a usable self-pointing symbol |
6dd12ef2 CY |
513 | (set cname cname) |
514 | ||
515 | ;; These two tests must be created right away so we can have self- | |
516 | ;; referencing classes. ei, a class whose slot can contain only | |
517 | ;; pointers to itself. | |
518 | ||
519 | ;; Create the test function | |
520 | (let ((csym (intern (concat (symbol-name cname) "-p")))) | |
521 | (fset csym | |
522 | (list 'lambda (list 'obj) | |
523 | (format "Test OBJ to see if it an object of type %s" cname) | |
524 | (list 'and '(eieio-object-p obj) | |
525 | (list 'same-class-p 'obj cname))))) | |
526 | ||
527 | ;; Make sure the method invocation order is a valid value. | |
528 | (let ((io (class-option-assoc options :method-invocation-order))) | |
a2930e43 | 529 | (when (and io (not (member io '(:depth-first :breadth-first :c3)))) |
6dd12ef2 CY |
530 | (error "Method invocation order %s is not allowed" io) |
531 | )) | |
532 | ||
533 | ;; Create a handy child test too | |
534 | (let ((csym (intern (concat (symbol-name cname) "-child-p")))) | |
535 | (fset csym | |
536 | `(lambda (obj) | |
537 | ,(format | |
538 | "Test OBJ to see if it an object is a child of type %s" | |
539 | cname) | |
540 | (and (eieio-object-p obj) | |
541 | (object-of-class-p obj ,cname)))) | |
542 | ||
543 | ;; When using typep, (typep OBJ 'myclass) returns t for objects which | |
544 | ;; are subclasses of myclass. For our predicates, however, it is | |
545 | ;; important for EIEIO to be backwards compatible, where | |
546 | ;; myobject-p, and myobject-child-p are different. | |
547 | ;; "cl" uses this technique to specify symbols with specific typep | |
548 | ;; test, so we can let typep have the CLOS documented behavior | |
549 | ;; while keeping our above predicate clean. | |
6dd12ef2 | 550 | |
67868d26 CY |
551 | ;; It would be cleaner to use `defsetf' here, but that requires cl |
552 | ;; at runtime. | |
553 | (put cname 'cl-deftype-handler | |
554 | (list 'lambda () `(list 'satisfies (quote ,csym))))) | |
6dd12ef2 | 555 | |
c7015153 | 556 | ;; before adding new slots, let's add all the methods and classes |
6dd12ef2 CY |
557 | ;; in from the parent class |
558 | (eieio-copy-parents-into-subclass newc superclasses) | |
559 | ||
560 | ;; Store the new class vector definition into the symbol. We need to | |
561 | ;; do this first so that we can call defmethod for the accessor. | |
562 | ;; The vector will be updated by the following while loop and will not | |
563 | ;; need to be stored a second time. | |
564 | (put cname 'eieio-class-definition newc) | |
565 | ||
566 | ;; Query each slot in the declaration list and mangle into the | |
567 | ;; class structure I have defined. | |
568 | (while slots | |
569 | (let* ((slot1 (car slots)) | |
570 | (name (car slot1)) | |
571 | (slot (cdr slot1)) | |
572 | (acces (plist-get slot ':accessor)) | |
573 | (init (or (plist-get slot ':initform) | |
574 | (if (member ':initform slot) nil | |
575 | eieio-unbound))) | |
576 | (initarg (plist-get slot ':initarg)) | |
577 | (docstr (plist-get slot ':documentation)) | |
578 | (prot (plist-get slot ':protection)) | |
579 | (reader (plist-get slot ':reader)) | |
580 | (writer (plist-get slot ':writer)) | |
581 | (alloc (plist-get slot ':allocation)) | |
582 | (type (plist-get slot ':type)) | |
583 | (custom (plist-get slot ':custom)) | |
584 | (label (plist-get slot ':label)) | |
585 | (customg (plist-get slot ':group)) | |
586 | (printer (plist-get slot ':printer)) | |
587 | ||
588 | (skip-nil (class-option-assoc options :allow-nil-initform)) | |
589 | ) | |
590 | ||
591 | (if eieio-error-unsupported-class-tags | |
592 | (let ((tmp slot)) | |
593 | (while tmp | |
594 | (if (not (member (car tmp) '(:accessor | |
595 | :initform | |
596 | :initarg | |
597 | :documentation | |
598 | :protection | |
599 | :reader | |
600 | :writer | |
601 | :allocation | |
602 | :type | |
603 | :custom | |
604 | :label | |
605 | :group | |
606 | :printer | |
607 | :allow-nil-initform | |
608 | :custom-groups))) | |
609 | (signal 'invalid-slot-type (list (car tmp)))) | |
610 | (setq tmp (cdr (cdr tmp)))))) | |
611 | ||
612 | ;; Clean up the meaning of protection. | |
613 | (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) | |
614 | ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) | |
615 | ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) | |
616 | ((eq prot nil) nil) | |
617 | (t (signal 'invalid-slot-type (list ':protection prot)))) | |
618 | ||
619 | ;; Make sure the :allocation parameter has a valid value. | |
620 | (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) | |
621 | (signal 'invalid-slot-type (list ':allocation alloc))) | |
622 | ||
623 | ;; The default type specifier is supposed to be t, meaning anything. | |
624 | (if (not type) (setq type t)) | |
625 | ||
626 | ;; Label is nil, or a string | |
627 | (if (not (or (null label) (stringp label))) | |
628 | (signal 'invalid-slot-type (list ':label label))) | |
629 | ||
630 | ;; Is there an initarg, but allocation of class? | |
631 | (if (and initarg (eq alloc :class)) | |
632 | (message "Class allocated slots do not need :initarg")) | |
633 | ||
634 | ;; intern the symbol so we can use it blankly | |
635 | (if initarg (set initarg initarg)) | |
636 | ||
637 | ;; The customgroup should be a list of symbols | |
638 | (cond ((null customg) | |
639 | (setq customg '(default))) | |
640 | ((not (listp customg)) | |
641 | (setq customg (list customg)))) | |
642 | ;; The customgroup better be a symbol, or list of symbols. | |
643 | (mapc (lambda (cg) | |
644 | (if (not (symbolp cg)) | |
645 | (signal 'invalid-slot-type (list ':group cg)))) | |
646 | customg) | |
647 | ||
648 | ;; First up, add this slot into our new class. | |
649 | (eieio-add-new-slot newc name init docstr type custom label customg printer | |
650 | prot initarg alloc 'defaultoverride skip-nil) | |
651 | ||
652 | ;; We need to id the group, and store them in a group list attribute. | |
653 | (mapc (lambda (cg) (add-to-list 'groups cg)) customg) | |
654 | ||
655 | ;; anyone can have an accessor function. This creates a function | |
656 | ;; of the specified name, and also performs a `defsetf' if applicable | |
657 | ;; so that users can `setf' the space returned by this function | |
658 | (if acces | |
659 | (progn | |
9869b3ae SM |
660 | (eieio--defmethod |
661 | acces (if (eq alloc :class) :static :primary) cname | |
662 | `(lambda (this) | |
663 | ,(format | |
6dd12ef2 CY |
664 | "Retrieves the slot `%s' from an object of class `%s'" |
665 | name cname) | |
9869b3ae SM |
666 | (if (slot-boundp this ',name) |
667 | (eieio-oref this ',name) | |
6dd12ef2 | 668 | ;; Else - Some error? nil? |
67868d26 CY |
669 | nil))) |
670 | ||
671 | ;; Provide a setf method. It would be cleaner to use | |
672 | ;; defsetf, but that would require CL at runtime. | |
673 | (put acces 'setf-method | |
674 | `(lambda (widget) | |
675 | (let* ((--widget-sym-- (make-symbol "--widget--")) | |
676 | (--store-sym-- (make-symbol "--store--"))) | |
677 | (list | |
678 | (list --widget-sym--) | |
679 | (list widget) | |
680 | (list --store-sym--) | |
681 | (list 'eieio-oset --widget-sym-- '',name --store-sym--) | |
682 | (list 'getfoo --widget-sym--))))))) | |
683 | ||
6dd12ef2 CY |
684 | ;; If a writer is defined, then create a generic method of that |
685 | ;; name whose purpose is to set the value of the slot. | |
686 | (if writer | |
9869b3ae SM |
687 | (eieio--defmethod |
688 | writer nil cname | |
689 | `(lambda (this value) | |
690 | ,(format "Set the slot `%s' of an object of class `%s'" | |
6dd12ef2 | 691 | name cname) |
9869b3ae | 692 | (setf (slot-value this ',name) value)))) |
6dd12ef2 CY |
693 | ;; If a reader is defined, then create a generic method |
694 | ;; of that name whose purpose is to access this slot value. | |
695 | (if reader | |
9869b3ae SM |
696 | (eieio--defmethod |
697 | reader nil cname | |
698 | `(lambda (this) | |
699 | ,(format "Access the slot `%s' from object of class `%s'" | |
6dd12ef2 | 700 | name cname) |
9869b3ae | 701 | (slot-value this ',name)))) |
6dd12ef2 CY |
702 | ) |
703 | (setq slots (cdr slots))) | |
704 | ||
705 | ;; Now that everything has been loaded up, all our lists are backwards! Fix that up now. | |
706 | (aset newc class-public-a (nreverse (aref newc class-public-a))) | |
707 | (aset newc class-public-d (nreverse (aref newc class-public-d))) | |
708 | (aset newc class-public-doc (nreverse (aref newc class-public-doc))) | |
709 | (aset newc class-public-type | |
710 | (apply 'vector (nreverse (aref newc class-public-type)))) | |
711 | (aset newc class-public-custom (nreverse (aref newc class-public-custom))) | |
712 | (aset newc class-public-custom-label (nreverse (aref newc class-public-custom-label))) | |
713 | (aset newc class-public-custom-group (nreverse (aref newc class-public-custom-group))) | |
714 | (aset newc class-public-printer (nreverse (aref newc class-public-printer))) | |
715 | (aset newc class-protection (nreverse (aref newc class-protection))) | |
716 | (aset newc class-initarg-tuples (nreverse (aref newc class-initarg-tuples))) | |
717 | ||
718 | ;; The storage for class-class-allocation-type needs to be turned into | |
719 | ;; a vector now. | |
720 | (aset newc class-class-allocation-type | |
721 | (apply 'vector (aref newc class-class-allocation-type))) | |
722 | ||
723 | ;; Also, take class allocated values, and vectorize them for speed. | |
724 | (aset newc class-class-allocation-values | |
725 | (apply 'vector (aref newc class-class-allocation-values))) | |
726 | ||
727 | ;; Attach slot symbols into an obarray, and store the index of | |
728 | ;; this slot as the variable slot in this new symbol. We need to | |
729 | ;; know about primes, because obarrays are best set in vectors of | |
730 | ;; prime number length, and we also need to make our vector small | |
731 | ;; to save space, and also optimal for the number of items we have. | |
732 | (let* ((cnt 0) | |
733 | (pubsyms (aref newc class-public-a)) | |
734 | (prots (aref newc class-protection)) | |
735 | (l (length pubsyms)) | |
736 | (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 | |
737 | 53 59 61 67 71 73 79 83 89 97 101 ))) | |
738 | (while (and primes (< (car primes) l)) | |
739 | (setq primes (cdr primes))) | |
740 | (car primes))) | |
741 | (oa (make-vector vl 0)) | |
742 | (newsym)) | |
743 | (while pubsyms | |
744 | (setq newsym (intern (symbol-name (car pubsyms)) oa)) | |
745 | (set newsym cnt) | |
746 | (setq cnt (1+ cnt)) | |
747 | (if (car prots) (put newsym 'protection (car prots))) | |
748 | (setq pubsyms (cdr pubsyms) | |
749 | prots (cdr prots))) | |
750 | (aset newc class-symbol-obarray oa) | |
751 | ) | |
752 | ||
753 | ;; Create the constructor function | |
754 | (if (class-option-assoc options :abstract) | |
755 | ;; Abstract classes cannot be instantiated. Say so. | |
756 | (let ((abs (class-option-assoc options :abstract))) | |
757 | (if (not (stringp abs)) | |
758 | (setq abs (format "Class %s is abstract" cname))) | |
759 | (fset cname | |
760 | `(lambda (&rest stuff) | |
761 | ,(format "You cannot create a new object of type %s" cname) | |
762 | (error ,abs)))) | |
763 | ||
764 | ;; Non-abstract classes need a constructor. | |
765 | (fset cname | |
766 | `(lambda (newname &rest slots) | |
767 | ,(format "Create a new object with name NAME of class type %s" cname) | |
768 | (apply 'constructor ,cname newname slots))) | |
769 | ) | |
770 | ||
771 | ;; Set up a specialized doc string. | |
772 | ;; Use stored value since it is calculated in a non-trivial way | |
773 | (put cname 'variable-documentation | |
774 | (class-option-assoc options :documentation)) | |
775 | ||
776 | ;; We have a list of custom groups. Store them into the options. | |
777 | (let ((g (class-option-assoc options :custom-groups))) | |
778 | (mapc (lambda (cg) (add-to-list 'g cg)) groups) | |
779 | (if (memq :custom-groups options) | |
780 | (setcar (cdr (memq :custom-groups options)) g) | |
781 | (setq options (cons :custom-groups (cons g options))))) | |
782 | ||
783 | ;; Set up the options we have collected. | |
784 | (aset newc class-options options) | |
785 | ||
786 | ;; if this is a superclass, clear out parent (which was set to the | |
787 | ;; default superclass eieio-default-superclass) | |
788 | (if clearparent (aset newc class-parent nil)) | |
789 | ||
790 | ;; Create the cached default object. | |
791 | (let ((cache (make-vector (+ (length (aref newc class-public-a)) | |
792 | 3) nil))) | |
793 | (aset cache 0 'object) | |
794 | (aset cache object-class cname) | |
795 | (aset cache object-name 'default-cache-object) | |
796 | (let ((eieio-skip-typecheck t)) | |
797 | ;; All type-checking has been done to our satisfaction | |
798 | ;; before this call. Don't waste our time in this call.. | |
799 | (eieio-set-defaults cache t)) | |
800 | (aset newc class-default-object-cache cache)) | |
801 | ||
802 | ;; Return our new class object | |
803 | ;; newc | |
804 | cname | |
805 | )) | |
806 | ||
807 | (defun eieio-perform-slot-validation-for-default (slot spec value skipnil) | |
808 | "For SLOT, signal if SPEC does not match VALUE. | |
a8f316ca | 809 | If SKIPNIL is non-nil, then if VALUE is nil return t instead." |
a2930e43 EL |
810 | (if (and (not (eieio-eval-default-p value)) |
811 | (not eieio-skip-typecheck) | |
812 | (not (and skipnil (null value))) | |
813 | (not (eieio-perform-slot-validation spec value))) | |
814 | (signal 'invalid-slot-type (list slot spec value)))) | |
6dd12ef2 CY |
815 | |
816 | (defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc | |
817 | &optional defaultoverride skipnil) | |
818 | "Add into NEWC attribute A. | |
819 | If A already exists in NEWC, then do nothing. If it doesn't exist, | |
a8f316ca | 820 | then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. |
6dd12ef2 CY |
821 | Argument ALLOC specifies if the slot is allocated per instance, or per class. |
822 | If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, | |
a8f316ca | 823 | we must override its value for a default. |
6dd12ef2 CY |
824 | Optional argument SKIPNIL indicates if type checking should be skipped |
825 | if default value is nil." | |
826 | ;; Make sure we duplicate those items that are sequences. | |
827 | (condition-case nil | |
828 | (if (sequencep d) (setq d (copy-sequence d))) | |
c7015153 | 829 | ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. |
6dd12ef2 CY |
830 | (error nil)) |
831 | (if (sequencep type) (setq type (copy-sequence type))) | |
832 | (if (sequencep cust) (setq cust (copy-sequence cust))) | |
833 | (if (sequencep custg) (setq custg (copy-sequence custg))) | |
834 | ||
835 | ;; To prevent override information w/out specification of storage, | |
836 | ;; we need to do this little hack. | |
837 | (if (member a (aref newc class-class-allocation-a)) (setq alloc ':class)) | |
838 | ||
839 | (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) | |
840 | ;; In this case, we modify the INSTANCE version of a given slot. | |
841 | ||
842 | (progn | |
843 | ||
844 | ;; Only add this element if it is so-far unique | |
845 | (if (not (member a (aref newc class-public-a))) | |
846 | (progn | |
847 | (eieio-perform-slot-validation-for-default a type d skipnil) | |
848 | (aset newc class-public-a (cons a (aref newc class-public-a))) | |
849 | (aset newc class-public-d (cons d (aref newc class-public-d))) | |
850 | (aset newc class-public-doc (cons doc (aref newc class-public-doc))) | |
851 | (aset newc class-public-type (cons type (aref newc class-public-type))) | |
852 | (aset newc class-public-custom (cons cust (aref newc class-public-custom))) | |
853 | (aset newc class-public-custom-label (cons label (aref newc class-public-custom-label))) | |
854 | (aset newc class-public-custom-group (cons custg (aref newc class-public-custom-group))) | |
855 | (aset newc class-public-printer (cons print (aref newc class-public-printer))) | |
856 | (aset newc class-protection (cons prot (aref newc class-protection))) | |
857 | (aset newc class-initarg-tuples (cons (cons init a) (aref newc class-initarg-tuples))) | |
858 | ) | |
859 | ;; When defaultoverride is true, we are usually adding new local | |
860 | ;; attributes which must override the default value of any slot | |
861 | ;; passed in by one of the parent classes. | |
862 | (when defaultoverride | |
863 | ;; There is a match, and we must override the old value. | |
864 | (let* ((ca (aref newc class-public-a)) | |
865 | (np (member a ca)) | |
866 | (num (- (length ca) (length np))) | |
867 | (dp (if np (nthcdr num (aref newc class-public-d)) | |
868 | nil)) | |
869 | (tp (if np (nth num (aref newc class-public-type)))) | |
870 | ) | |
871 | (if (not np) | |
a8f316ca | 872 | (error "EIEIO internal error overriding default value for %s" |
6dd12ef2 CY |
873 | a) |
874 | ;; If type is passed in, is it the same? | |
875 | (if (not (eq type t)) | |
876 | (if (not (equal type tp)) | |
877 | (error | |
878 | "Child slot type `%s' does not match inherited type `%s' for `%s'" | |
879 | type tp a))) | |
880 | ;; If we have a repeat, only update the initarg... | |
881 | (unless (eq d eieio-unbound) | |
882 | (eieio-perform-slot-validation-for-default a tp d skipnil) | |
883 | (setcar dp d)) | |
884 | ;; If we have a new initarg, check for it. | |
885 | (when init | |
886 | (let* ((inits (aref newc class-initarg-tuples)) | |
887 | (inita (rassq a inits))) | |
888 | ;; Replace the CAR of the associate INITA. | |
889 | ;;(message "Initarg: %S replace %s" inita init) | |
890 | (setcar inita init) | |
891 | )) | |
892 | ||
893 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is | |
894 | ;; checked and SHOULD match the superclass | |
895 | ;; protection. Otherwise an error is thrown. However | |
896 | ;; I wonder if a more flexible schedule might be | |
897 | ;; implemented. | |
898 | ;; | |
899 | ;; EML - We used to have (if prot... here, | |
900 | ;; but a prot of 'nil means public. | |
901 | ;; | |
902 | (let ((super-prot (nth num (aref newc class-protection))) | |
903 | ) | |
904 | (if (not (eq prot super-prot)) | |
905 | (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" | |
906 | prot super-prot a))) | |
907 | ;; End original PLN | |
908 | ||
909 | ;; PLN Tue Jun 26 11:57:06 2007 : | |
67868d26 CY |
910 | ;; Do a non redundant combination of ancient custom |
911 | ;; groups and new ones. | |
6dd12ef2 | 912 | (when custg |
67868d26 CY |
913 | (let* ((groups |
914 | (nthcdr num (aref newc class-public-custom-group))) | |
915 | (list1 (car groups)) | |
916 | (list2 (if (listp custg) custg (list custg)))) | |
917 | (if (< (length list1) (length list2)) | |
918 | (setq list1 (prog1 list2 (setq list2 list1)))) | |
919 | (dolist (elt list2) | |
920 | (unless (memq elt list1) | |
921 | (push elt list1))) | |
922 | (setcar groups list1))) | |
6dd12ef2 CY |
923 | ;; End PLN |
924 | ||
925 | ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is | |
926 | ;; set, simply replaces the old one. | |
927 | (when cust | |
928 | ;; (message "Custom type redefined to %s" cust) | |
929 | (setcar (nthcdr num (aref newc class-public-custom)) cust)) | |
930 | ||
931 | ;; If a new label is specified, it simply replaces | |
932 | ;; the old one. | |
933 | (when label | |
934 | ;; (message "Custom label redefined to %s" label) | |
935 | (setcar (nthcdr num (aref newc class-public-custom-label)) label)) | |
936 | ;; End PLN | |
937 | ||
938 | ;; PLN Sat Jun 30 17:24:42 2007 : when a new | |
939 | ;; doc is specified, simply replaces the old one. | |
940 | (when doc | |
941 | ;;(message "Documentation redefined to %s" doc) | |
942 | (setcar (nthcdr num (aref newc class-public-doc)) | |
943 | doc)) | |
944 | ;; End PLN | |
945 | ||
946 | ;; If a new printer is specified, it simply replaces | |
947 | ;; the old one. | |
948 | (when print | |
949 | ;; (message "printer redefined to %s" print) | |
950 | (setcar (nthcdr num (aref newc class-public-printer)) print)) | |
951 | ||
952 | ))) | |
953 | )) | |
954 | ||
955 | ;; CLASS ALLOCATED SLOTS | |
956 | (let ((value (eieio-default-eval-maybe d))) | |
957 | (if (not (member a (aref newc class-class-allocation-a))) | |
958 | (progn | |
959 | (eieio-perform-slot-validation-for-default a type value skipnil) | |
960 | ;; Here we have found a :class version of a slot. This | |
91af3942 | 961 | ;; requires a very different approach. |
6dd12ef2 CY |
962 | (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a))) |
963 | (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc))) | |
964 | (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type))) | |
965 | (aset newc class-class-allocation-custom (cons cust (aref newc class-class-allocation-custom))) | |
966 | (aset newc class-class-allocation-custom-label (cons label (aref newc class-class-allocation-custom-label))) | |
967 | (aset newc class-class-allocation-custom-group (cons custg (aref newc class-class-allocation-custom-group))) | |
968 | (aset newc class-class-allocation-protection (cons prot (aref newc class-class-allocation-protection))) | |
969 | ;; Default value is stored in the 'values section, since new objects | |
970 | ;; can't initialize from this element. | |
971 | (aset newc class-class-allocation-values (cons value (aref newc class-class-allocation-values)))) | |
972 | (when defaultoverride | |
973 | ;; There is a match, and we must override the old value. | |
974 | (let* ((ca (aref newc class-class-allocation-a)) | |
975 | (np (member a ca)) | |
976 | (num (- (length ca) (length np))) | |
977 | (dp (if np | |
978 | (nthcdr num | |
979 | (aref newc class-class-allocation-values)) | |
980 | nil)) | |
981 | (tp (if np (nth num (aref newc class-class-allocation-type)) | |
982 | nil))) | |
983 | (if (not np) | |
a8f316ca | 984 | (error "EIEIO internal error overriding default value for %s" |
6dd12ef2 CY |
985 | a) |
986 | ;; If type is passed in, is it the same? | |
987 | (if (not (eq type t)) | |
988 | (if (not (equal type tp)) | |
989 | (error | |
990 | "Child slot type `%s' does not match inherited type `%s' for `%s'" | |
991 | type tp a))) | |
992 | ;; EML - Note: the only reason to override a class bound slot | |
993 | ;; is to change the default, so allow unbound in. | |
994 | ||
ee7683eb | 995 | ;; If we have a repeat, only update the value... |
6dd12ef2 CY |
996 | (eieio-perform-slot-validation-for-default a tp value skipnil) |
997 | (setcar dp value)) | |
998 | ||
999 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is | |
1000 | ;; checked and SHOULD match the superclass | |
1001 | ;; protection. Otherwise an error is thrown. However | |
1002 | ;; I wonder if a more flexible schedule might be | |
1003 | ;; implemented. | |
1004 | (let ((super-prot | |
1005 | (car (nthcdr num (aref newc class-class-allocation-protection))))) | |
1006 | (if (not (eq prot super-prot)) | |
1007 | (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" | |
1008 | prot super-prot a))) | |
67868d26 CY |
1009 | ;; Do a non redundant combination of ancient custom groups |
1010 | ;; and new ones. | |
6dd12ef2 | 1011 | (when custg |
67868d26 CY |
1012 | (let* ((groups |
1013 | (nthcdr num (aref newc class-class-allocation-custom-group))) | |
1014 | (list1 (car groups)) | |
1015 | (list2 (if (listp custg) custg (list custg)))) | |
1016 | (if (< (length list1) (length list2)) | |
1017 | (setq list1 (prog1 list2 (setq list2 list1)))) | |
1018 | (dolist (elt list2) | |
1019 | (unless (memq elt list1) | |
1020 | (push elt list1))) | |
1021 | (setcar groups list1))) | |
6dd12ef2 CY |
1022 | |
1023 | ;; PLN Sat Jun 30 17:24:42 2007 : when a new | |
1024 | ;; doc is specified, simply replaces the old one. | |
1025 | (when doc | |
1026 | ;;(message "Documentation redefined to %s" doc) | |
1027 | (setcar (nthcdr num (aref newc class-class-allocation-doc)) | |
1028 | doc)) | |
1029 | ;; End PLN | |
1030 | ||
1031 | ;; If a new printer is specified, it simply replaces | |
1032 | ;; the old one. | |
1033 | (when print | |
1034 | ;; (message "printer redefined to %s" print) | |
1035 | (setcar (nthcdr num (aref newc class-class-allocation-printer)) print)) | |
1036 | ||
1037 | )) | |
1038 | )) | |
1039 | )) | |
1040 | ||
1041 | (defun eieio-copy-parents-into-subclass (newc parents) | |
1042 | "Copy into NEWC the slots of PARENTS. | |
9ffe3f52 | 1043 | Follow the rules of not overwriting early parents when applying to |
6dd12ef2 CY |
1044 | the new child class." |
1045 | (let ((ps (aref newc class-parent)) | |
1046 | (sn (class-option-assoc (aref newc class-options) | |
1047 | ':allow-nil-initform))) | |
1048 | (while ps | |
1049 | ;; First, duplicate all the slots of the parent. | |
1050 | (let ((pcv (class-v (car ps)))) | |
1051 | (let ((pa (aref pcv class-public-a)) | |
1052 | (pd (aref pcv class-public-d)) | |
1053 | (pdoc (aref pcv class-public-doc)) | |
1054 | (ptype (aref pcv class-public-type)) | |
1055 | (pcust (aref pcv class-public-custom)) | |
1056 | (plabel (aref pcv class-public-custom-label)) | |
1057 | (pcustg (aref pcv class-public-custom-group)) | |
1058 | (printer (aref pcv class-public-printer)) | |
1059 | (pprot (aref pcv class-protection)) | |
1060 | (pinit (aref pcv class-initarg-tuples)) | |
1061 | (i 0)) | |
1062 | (while pa | |
1063 | (eieio-add-new-slot newc | |
1064 | (car pa) (car pd) (car pdoc) (aref ptype i) | |
1065 | (car pcust) (car plabel) (car pcustg) | |
1066 | (car printer) | |
1067 | (car pprot) (car-safe (car pinit)) nil nil sn) | |
1068 | ;; Increment each value. | |
1069 | (setq pa (cdr pa) | |
1070 | pd (cdr pd) | |
1071 | pdoc (cdr pdoc) | |
1072 | i (1+ i) | |
1073 | pcust (cdr pcust) | |
1074 | plabel (cdr plabel) | |
1075 | pcustg (cdr pcustg) | |
1076 | printer (cdr printer) | |
1077 | pprot (cdr pprot) | |
1078 | pinit (cdr pinit)) | |
1079 | )) ;; while/let | |
1080 | ;; Now duplicate all the class alloc slots. | |
1081 | (let ((pa (aref pcv class-class-allocation-a)) | |
1082 | (pdoc (aref pcv class-class-allocation-doc)) | |
1083 | (ptype (aref pcv class-class-allocation-type)) | |
1084 | (pcust (aref pcv class-class-allocation-custom)) | |
1085 | (plabel (aref pcv class-class-allocation-custom-label)) | |
1086 | (pcustg (aref pcv class-class-allocation-custom-group)) | |
1087 | (printer (aref pcv class-class-allocation-printer)) | |
1088 | (pprot (aref pcv class-class-allocation-protection)) | |
1089 | (pval (aref pcv class-class-allocation-values)) | |
1090 | (i 0)) | |
1091 | (while pa | |
1092 | (eieio-add-new-slot newc | |
1093 | (car pa) (aref pval i) (car pdoc) (aref ptype i) | |
1094 | (car pcust) (car plabel) (car pcustg) | |
1095 | (car printer) | |
1096 | (car pprot) nil ':class sn) | |
1097 | ;; Increment each value. | |
1098 | (setq pa (cdr pa) | |
1099 | pdoc (cdr pdoc) | |
1100 | pcust (cdr pcust) | |
1101 | plabel (cdr plabel) | |
1102 | pcustg (cdr pcustg) | |
1103 | printer (cdr printer) | |
1104 | pprot (cdr pprot) | |
1105 | i (1+ i)) | |
1106 | ))) ;; while/let | |
1107 | ;; Loop over each parent class | |
1108 | (setq ps (cdr ps))) | |
1109 | )) | |
1110 | ||
1111 | ;;; CLOS style implementation of object creators. | |
1112 | ;; | |
1113 | (defun make-instance (class &rest initargs) | |
1114 | "Make a new instance of CLASS based on INITARGS. | |
1115 | CLASS is a class symbol. For example: | |
1116 | ||
1117 | (make-instance 'foo) | |
1118 | ||
1119 | INITARGS is a property list with keywords based on the :initarg | |
1120 | for each slot. For example: | |
1121 | ||
1122 | (make-instance 'foo :slot1 value1 :slotN valueN) | |
1123 | ||
9ffe3f52 | 1124 | Compatibility note: |
6dd12ef2 CY |
1125 | |
1126 | If the first element of INITARGS is a string, it is used as the | |
1127 | name of the class. | |
1128 | ||
1129 | In EIEIO, the class' constructor requires a name for use when printing. | |
1130 | `make-instance' in CLOS doesn't use names the way Emacs does, so the | |
1131 | class is used as the name slot instead when INITARGS doesn't start with | |
1132 | a string." | |
1133 | (if (and (car initargs) (stringp (car initargs))) | |
1134 | (apply (class-constructor class) initargs) | |
1135 | (apply (class-constructor class) | |
1136 | (cond ((symbolp class) (symbol-name class)) | |
1137 | (t (format "%S" class))) | |
1138 | initargs))) | |
1139 | ||
1140 | \f | |
1141 | ;;; CLOS methods and generics | |
1142 | ;; | |
d1dc2cc2 SM |
1143 | |
1144 | (put 'eieio--defalias 'byte-hunk-handler | |
1145 | #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) | |
1146 | (defun eieio--defalias (name body) | |
1147 | "Like `defalias', but with less side-effects. | |
1148 | More specifically, it has no side-effects at all when the new function | |
1149 | definition is the same (`eq') as the old one." | |
1150 | (unless (and (fboundp name) | |
1151 | (eq (symbol-function name) body)) | |
1152 | (defalias name body))) | |
1153 | ||
6dd12ef2 | 1154 | (defmacro defgeneric (method args &optional doc-string) |
a8f316ca | 1155 | "Create a generic function METHOD. |
6dd12ef2 | 1156 | DOC-STRING is the base documentation for this class. A generic |
a8f316ca JB |
1157 | function has no body, as its purpose is to decide which method body |
1158 | is appropriate to use. Uses `defmethod' to create methods, and calls | |
1159 | `defgeneric' for you. With this implementation the ARGS are | |
6dd12ef2 CY |
1160 | currently ignored. You can use `defgeneric' to apply specialized |
1161 | top level documentation to a method." | |
d1dc2cc2 SM |
1162 | `(eieio--defalias ',method |
1163 | (eieio--defgeneric-init-form ',method ,doc-string))) | |
1164 | ||
1165 | (defun eieio--defgeneric-init-form (method doc-string) | |
1166 | "Form to use for the initial definition of a generic." | |
1167 | (cond | |
1168 | ((or (not (fboundp method)) | |
1169 | (eq 'autoload (car-safe (symbol-function method)))) | |
1170 | ;; Make sure the method tables are installed. | |
1171 | (eieiomt-install method) | |
1172 | ;; Construct the actual body of this function. | |
1173 | (eieio-defgeneric-form method doc-string)) | |
1174 | ((generic-p method) (symbol-function method)) ;Leave it as-is. | |
1175 | (t (error "You cannot create a generic/method over an existing symbol: %s" | |
1176 | method)))) | |
6dd12ef2 CY |
1177 | |
1178 | (defun eieio-defgeneric-form (method doc-string) | |
1179 | "The lambda form that would be used as the function defined on METHOD. | |
1180 | All methods should call the same EIEIO function for dispatch. | |
1181 | DOC-STRING is the documentation attached to METHOD." | |
1182 | `(lambda (&rest local-args) | |
1183 | ,doc-string | |
1184 | (eieio-generic-call (quote ,method) local-args))) | |
1185 | ||
1186 | (defsubst eieio-defgeneric-reset-generic-form (method) | |
1187 | "Setup METHOD to call the generic form." | |
1188 | (let ((doc-string (documentation method))) | |
1189 | (fset method (eieio-defgeneric-form method doc-string)))) | |
1190 | ||
1191 | (defun eieio-defgeneric-form-primary-only (method doc-string) | |
1192 | "The lambda form that would be used as the function defined on METHOD. | |
1193 | All methods should call the same EIEIO function for dispatch. | |
1194 | DOC-STRING is the documentation attached to METHOD." | |
1195 | `(lambda (&rest local-args) | |
1196 | ,doc-string | |
1197 | (eieio-generic-call-primary-only (quote ,method) local-args))) | |
1198 | ||
1199 | (defsubst eieio-defgeneric-reset-generic-form-primary-only (method) | |
1200 | "Setup METHOD to call the generic form." | |
1201 | (let ((doc-string (documentation method))) | |
1202 | (fset method (eieio-defgeneric-form-primary-only method doc-string)))) | |
1203 | ||
1204 | (defun eieio-defgeneric-form-primary-only-one (method doc-string | |
1205 | class | |
1206 | impl | |
1207 | ) | |
1208 | "The lambda form that would be used as the function defined on METHOD. | |
1209 | All methods should call the same EIEIO function for dispatch. | |
1210 | DOC-STRING is the documentation attached to METHOD. | |
1211 | CLASS is the class symbol needed for private method access. | |
1212 | IMPL is the symbol holding the method implementation." | |
1213 | ;; NOTE: I tried out byte compiling this little fcn. Turns out it | |
1214 | ;; is faster to execute this for not byte-compiled. ie, install this, | |
1215 | ;; then measure calls going through here. I wonder why. | |
1216 | (require 'bytecomp) | |
3e21b6a7 SM |
1217 | (let ((byte-compile-warnings nil)) |
1218 | (byte-compile | |
6dd12ef2 CY |
1219 | `(lambda (&rest local-args) |
1220 | ,doc-string | |
1221 | ;; This is a cool cheat. Usually we need to look up in the | |
1222 | ;; method table to find out if there is a method or not. We can | |
1223 | ;; instead make that determination at load time when there is | |
1224 | ;; only one method. If the first arg is not a child of the class | |
1225 | ;; of that one implementation, then clearly, there is no method def. | |
1226 | (if (not (eieio-object-p (car local-args))) | |
1227 | ;; Not an object. Just signal. | |
3e21b6a7 | 1228 | (signal 'no-method-definition |
b1ef1257 | 1229 | (list ',method local-args)) |
6dd12ef2 CY |
1230 | |
1231 | ;; We do have an object. Make sure it is the right type. | |
1232 | (if ,(if (eq class eieio-default-superclass) | |
b1ef1257 | 1233 | nil ; default superclass means just an obj. Already asked. |
6dd12ef2 | 1234 | `(not (child-of-class-p (aref (car local-args) object-class) |
b1ef1257 | 1235 | ',class))) |
6dd12ef2 CY |
1236 | |
1237 | ;; If not the right kind of object, call no applicable | |
1238 | (apply 'no-applicable-method (car local-args) | |
b1ef1257 | 1239 | ',method local-args) |
6dd12ef2 CY |
1240 | |
1241 | ;; It is ok, do the call. | |
1242 | ;; Fill in inter-call variables then evaluate the method. | |
b1ef1257 | 1243 | (let ((scoped-class ',class) |
6dd12ef2 CY |
1244 | (eieio-generic-call-next-method-list nil) |
1245 | (eieio-generic-call-key method-primary) | |
b1ef1257 | 1246 | (eieio-generic-call-methodname ',method) |
6dd12ef2 CY |
1247 | (eieio-generic-call-arglst local-args) |
1248 | ) | |
b1ef1257 SM |
1249 | (apply #',impl local-args) |
1250 | ;;(,impl local-args) | |
3e21b6a7 | 1251 | ))))))) |
6dd12ef2 CY |
1252 | |
1253 | (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) | |
1254 | "Setup METHOD to call the generic form." | |
1255 | (let* ((doc-string (documentation method)) | |
1256 | (M (get method 'eieio-method-tree)) | |
1257 | (entry (car (aref M method-primary))) | |
1258 | ) | |
1259 | (fset method (eieio-defgeneric-form-primary-only-one | |
1260 | method doc-string | |
1261 | (car entry) | |
1262 | (cdr entry) | |
1263 | )))) | |
1264 | ||
6dd12ef2 | 1265 | (defun eieio-unbind-method-implementations (method) |
a8f316ca JB |
1266 | "Make the generic method METHOD have no implementations. |
1267 | It will leave the original generic function in place, | |
1268 | but remove reference to all implementations of METHOD." | |
6dd12ef2 CY |
1269 | (put method 'eieio-method-tree nil) |
1270 | (put method 'eieio-method-obarray nil)) | |
1271 | ||
1272 | (defmacro defmethod (method &rest args) | |
1273 | "Create a new METHOD through `defgeneric' with ARGS. | |
1274 | ||
a8f316ca | 1275 | The optional second argument KEY is a specifier that |
6dd12ef2 | 1276 | modifies how the method is called, including: |
a8f316ca JB |
1277 | :before - Method will be called before the :primary |
1278 | :primary - The default if not specified | |
1279 | :after - Method will be called after the :primary | |
1280 | :static - First arg could be an object or class | |
6dd12ef2 CY |
1281 | The next argument is the ARGLIST. The ARGLIST specifies the arguments |
1282 | to the method as with `defun'. The first argument can have a type | |
1283 | specifier, such as: | |
1284 | ((VARNAME CLASS) ARG2 ...) | |
1285 | where VARNAME is the name of the local variable for the method being | |
1286 | created. The CLASS is a class symbol for a class made with `defclass'. | |
1287 | A DOCSTRING comes after the ARGLIST, and is optional. | |
1288 | All the rest of the args are the BODY of the method. A method will | |
1289 | return the value of the last form in the BODY. | |
1290 | ||
1291 | Summary: | |
1292 | ||
1293 | (defmethod mymethod [:before | :primary | :after | :static] | |
1294 | ((typearg class-name) arg2 &optional opt &rest rest) | |
1295 | \"doc-string\" | |
1296 | body)" | |
9869b3ae | 1297 | (let* ((key (if (keywordp (car args)) (pop args))) |
876c194c | 1298 | (params (car args)) |
876c194c | 1299 | (arg1 (car params)) |
c4662635 | 1300 | (fargs (if (consp arg1) |
d1dc2cc2 SM |
1301 | (cons (car arg1) (cdr params)) |
1302 | params)) | |
1303 | (class (if (consp arg1) (nth 1 arg1))) | |
c4662635 | 1304 | (code `(lambda ,fargs ,@(cdr args)))) |
d1dc2cc2 SM |
1305 | `(progn |
1306 | ;; Make sure there is a generic and the byte-compiler sees it. | |
1307 | (defgeneric ,method ,args | |
1308 | ,(or (documentation code) | |
1309 | (format "Generically created method `%s'." method))) | |
31d55be9 | 1310 | (eieio--defmethod ',method ',key ',class #',code)))) |
9869b3ae SM |
1311 | |
1312 | (defun eieio--defmethod (method kind argclass code) | |
6dd12ef2 | 1313 | "Work part of the `defmethod' macro defining METHOD with ARGS." |
9869b3ae | 1314 | (let ((key |
93b6b5e1 | 1315 | ;; find optional keys |
9869b3ae SM |
1316 | (cond ((or (eq ':BEFORE kind) |
1317 | (eq ':before kind)) | |
93b6b5e1 | 1318 | method-before) |
9869b3ae SM |
1319 | ((or (eq ':AFTER kind) |
1320 | (eq ':after kind)) | |
93b6b5e1 | 1321 | method-after) |
9869b3ae SM |
1322 | ((or (eq ':PRIMARY kind) |
1323 | (eq ':primary kind)) | |
93b6b5e1 | 1324 | method-primary) |
9869b3ae SM |
1325 | ((or (eq ':STATIC kind) |
1326 | (eq ':static kind)) | |
93b6b5e1 SM |
1327 | method-static) |
1328 | ;; Primary key | |
9869b3ae | 1329 | (t method-primary)))) |
d1dc2cc2 SM |
1330 | ;; Make sure there is a generic (when called from defclass). |
1331 | (eieio--defalias | |
1332 | method (eieio--defgeneric-init-form | |
1333 | method (or (documentation code) | |
1334 | (format "Generically created method `%s'." method)))) | |
6dd12ef2 CY |
1335 | ;; create symbol for property to bind to. If the first arg is of |
1336 | ;; the form (varname vartype) and `vartype' is a class, then | |
1337 | ;; that class will be the type symbol. If not, then it will fall | |
1338 | ;; under the type `primary' which is a non-specific calling of the | |
1339 | ;; function. | |
9869b3ae | 1340 | (if argclass |
93b6b5e1 SM |
1341 | (if (not (class-p argclass)) |
1342 | (error "Unknown class type %s in method parameters" | |
9869b3ae | 1343 | argclass)) |
6dd12ef2 CY |
1344 | (if (= key -1) |
1345 | (signal 'wrong-type-argument (list :static 'non-class-arg))) | |
1346 | ;; generics are higher | |
a2930e43 | 1347 | (setq key (eieio-specialized-key-to-generic-key key))) |
6dd12ef2 | 1348 | ;; Put this lambda into the symbol so we can find it |
876c194c | 1349 | (eieiomt-add method code key argclass) |
6dd12ef2 CY |
1350 | ) |
1351 | ||
1352 | (when eieio-optimize-primary-methods-flag | |
1353 | ;; Optimizing step: | |
1354 | ;; | |
1355 | ;; If this method, after this setup, only has primary methods, then | |
1356 | ;; we can setup the generic that way. | |
1357 | (if (generic-primary-only-p method) | |
1358 | ;; If there is only one primary method, then we can go one more | |
1359 | ;; optimization step. | |
1360 | (if (generic-primary-only-one-p method) | |
1361 | (eieio-defgeneric-reset-generic-form-primary-only-one method) | |
1362 | (eieio-defgeneric-reset-generic-form-primary-only method)) | |
1363 | (eieio-defgeneric-reset-generic-form method))) | |
1364 | ||
1365 | method) | |
1366 | ||
1367 | ;;; Slot type validation | |
67868d26 CY |
1368 | |
1369 | ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid | |
1370 | ;; requiring the CL library at run-time. It can be eliminated if/when | |
1371 | ;; `typep' is merged into Emacs core. | |
1372 | (defun eieio--typep (val type) | |
1373 | (if (symbolp type) | |
1374 | (cond ((get type 'cl-deftype-handler) | |
1375 | (eieio--typep val (funcall (get type 'cl-deftype-handler)))) | |
1376 | ((eq type t) t) | |
1377 | ((eq type 'null) (null val)) | |
1378 | ((eq type 'atom) (atom val)) | |
1379 | ((eq type 'float) (and (numberp val) (not (integerp val)))) | |
1380 | ((eq type 'real) (numberp val)) | |
1381 | ((eq type 'fixnum) (integerp val)) | |
1382 | ((memq type '(character string-char)) (characterp val)) | |
1383 | (t | |
1384 | (let* ((name (symbol-name type)) | |
1385 | (namep (intern (concat name "p")))) | |
1386 | (if (fboundp namep) | |
1387 | (funcall `(lambda () (,namep val))) | |
1388 | (funcall `(lambda () | |
1389 | (,(intern (concat name "-p")) val))))))) | |
1390 | (cond ((get (car type) 'cl-deftype-handler) | |
1391 | (eieio--typep val (apply (get (car type) 'cl-deftype-handler) | |
1392 | (cdr type)))) | |
1393 | ((memq (car type) '(integer float real number)) | |
1394 | (and (eieio--typep val (car type)) | |
1395 | (or (memq (cadr type) '(* nil)) | |
1396 | (if (consp (cadr type)) | |
1397 | (> val (car (cadr type))) | |
1398 | (>= val (cadr type)))) | |
1399 | (or (memq (caddr type) '(* nil)) | |
1400 | (if (consp (car (cddr type))) | |
1401 | (< val (caar (cddr type))) | |
1402 | (<= val (car (cddr type))))))) | |
1403 | ((memq (car type) '(and or not)) | |
1404 | (eval (cons (car type) | |
1405 | (mapcar (lambda (x) | |
1406 | `(eieio--typep (quote ,val) (quote ,x))) | |
1407 | (cdr type))))) | |
1408 | ((memq (car type) '(member member*)) | |
1409 | (memql val (cdr type))) | |
1410 | ((eq (car type) 'satisfies) | |
1411 | (funcall `(lambda () (,(cadr type) val)))) | |
1412 | (t (error "Bad type spec: %s" type))))) | |
1413 | ||
6dd12ef2 CY |
1414 | (defun eieio-perform-slot-validation (spec value) |
1415 | "Return non-nil if SPEC does not match VALUE." | |
6dd12ef2 CY |
1416 | (or (eq spec t) ; t always passes |
1417 | (eq value eieio-unbound) ; unbound always passes | |
67868d26 | 1418 | (eieio--typep value spec))) |
6dd12ef2 CY |
1419 | |
1420 | (defun eieio-validate-slot-value (class slot-idx value slot) | |
a8f316ca | 1421 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. |
6dd12ef2 CY |
1422 | Checks the :type specifier. |
1423 | SLOT is the slot that is being checked, and is only used when throwing | |
a8f316ca | 1424 | an error." |
6dd12ef2 CY |
1425 | (if eieio-skip-typecheck |
1426 | nil | |
1427 | ;; Trim off object IDX junk added in for the object index. | |
1428 | (setq slot-idx (- slot-idx 3)) | |
1429 | (let ((st (aref (aref (class-v class) class-public-type) slot-idx))) | |
1430 | (if (not (eieio-perform-slot-validation st value)) | |
1431 | (signal 'invalid-slot-type (list class slot st value)))))) | |
1432 | ||
1433 | (defun eieio-validate-class-slot-value (class slot-idx value slot) | |
a8f316ca | 1434 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. |
6dd12ef2 CY |
1435 | Checks the :type specifier. |
1436 | SLOT is the slot that is being checked, and is only used when throwing | |
a8f316ca | 1437 | an error." |
6dd12ef2 CY |
1438 | (if eieio-skip-typecheck |
1439 | nil | |
1440 | (let ((st (aref (aref (class-v class) class-class-allocation-type) | |
1441 | slot-idx))) | |
1442 | (if (not (eieio-perform-slot-validation st value)) | |
1443 | (signal 'invalid-slot-type (list class slot st value)))))) | |
1444 | ||
1445 | (defun eieio-barf-if-slot-unbound (value instance slotname fn) | |
1446 | "Throw a signal if VALUE is a representation of an UNBOUND slot. | |
1447 | INSTANCE is the object being referenced. SLOTNAME is the offending | |
1448 | slot. If the slot is ok, return VALUE. | |
1449 | Argument FN is the function calling this verifier." | |
1450 | (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) | |
1451 | (slot-unbound instance (object-class instance) slotname fn) | |
1452 | value)) | |
1453 | ||
6dd12ef2 CY |
1454 | ;;; Get/Set slots in an object. |
1455 | ;; | |
1456 | (defmacro oref (obj slot) | |
1457 | "Retrieve the value stored in OBJ in the slot named by SLOT. | |
1458 | Slot is the name of the slot when created by `defclass' or the label | |
1459 | created by the :initarg tag." | |
1460 | `(eieio-oref ,obj (quote ,slot))) | |
1461 | ||
1462 | (defun eieio-oref (obj slot) | |
1463 | "Return the value in OBJ at SLOT in the object vector." | |
1464 | (if (not (or (eieio-object-p obj) (class-p obj))) | |
1465 | (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj))) | |
1466 | (if (not (symbolp slot)) | |
1467 | (signal 'wrong-type-argument (list 'symbolp slot))) | |
1468 | (if (class-p obj) (eieio-class-un-autoload obj)) | |
1469 | (let* ((class (if (class-p obj) obj (aref obj object-class))) | |
1470 | (c (eieio-slot-name-index class obj slot))) | |
1471 | (if (not c) | |
1472 | ;; It might be missing because it is a :class allocated slot. | |
c7015153 | 1473 | ;; Let's check that info out. |
6dd12ef2 CY |
1474 | (if (setq c (eieio-class-slot-name-index class slot)) |
1475 | ;; Oref that slot. | |
1476 | (aref (aref (class-v class) class-class-allocation-values) c) | |
1477 | ;; The slot-missing method is a cool way of allowing an object author | |
1478 | ;; to intercept missing slot definitions. Since it is also the LAST | |
a8f316ca | 1479 | ;; thing called in this fn, its return value would be retrieved. |
6dd12ef2 CY |
1480 | (slot-missing obj slot 'oref) |
1481 | ;;(signal 'invalid-slot-name (list (object-name obj) slot)) | |
1482 | ) | |
1483 | (if (not (eieio-object-p obj)) | |
1484 | (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1485 | (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) | |
1486 | ||
1487 | (defalias 'slot-value 'eieio-oref) | |
1488 | (defalias 'set-slot-value 'eieio-oset) | |
1489 | ||
1490 | (defmacro oref-default (obj slot) | |
a8f316ca | 1491 | "Get the default value of OBJ (maybe a class) for SLOT. |
6dd12ef2 CY |
1492 | The default value is the value installed in a class with the :initform |
1493 | tag. SLOT can be the slot name, or the tag specified by the :initarg | |
1494 | tag in the `defclass' call." | |
1495 | `(eieio-oref-default ,obj (quote ,slot))) | |
1496 | ||
1497 | (defun eieio-oref-default (obj slot) | |
a8f316ca JB |
1498 | "Do the work for the macro `oref-default' with similar parameters. |
1499 | Fills in OBJ's SLOT with its default value." | |
6dd12ef2 CY |
1500 | (if (not (or (eieio-object-p obj) (class-p obj))) (signal 'wrong-type-argument (list 'eieio-object-p obj))) |
1501 | (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) | |
1502 | (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj)) | |
1503 | (c (eieio-slot-name-index cl obj slot))) | |
1504 | (if (not c) | |
1505 | ;; It might be missing because it is a :class allocated slot. | |
c7015153 | 1506 | ;; Let's check that info out. |
6dd12ef2 CY |
1507 | (if (setq c |
1508 | (eieio-class-slot-name-index cl slot)) | |
1509 | ;; Oref that slot. | |
1510 | (aref (aref (class-v cl) class-class-allocation-values) | |
1511 | c) | |
1512 | (slot-missing obj slot 'oref-default) | |
1513 | ;;(signal 'invalid-slot-name (list (class-name cl) slot)) | |
1514 | ) | |
1515 | (eieio-barf-if-slot-unbound | |
1516 | (let ((val (nth (- c 3) (aref (class-v cl) class-public-d)))) | |
1517 | (eieio-default-eval-maybe val)) | |
1518 | obj cl 'oref-default)))) | |
1519 | ||
a2930e43 EL |
1520 | (defsubst eieio-eval-default-p (val) |
1521 | "Whether the default value VAL should be evaluated for use." | |
1522 | (and (consp val) (symbolp (car val)) (fboundp (car val)))) | |
1523 | ||
6dd12ef2 CY |
1524 | (defun eieio-default-eval-maybe (val) |
1525 | "Check VAL, and return what `oref-default' would provide." | |
a2930e43 EL |
1526 | (cond |
1527 | ;; Is it a function call? If so, evaluate it. | |
1528 | ((eieio-eval-default-p val) | |
1529 | (eval val)) | |
1530 | ;;;; check for quoted things, and unquote them | |
1531 | ;;((and (consp val) (eq (car val) 'quote)) | |
1532 | ;; (car (cdr val))) | |
1533 | ;; return it verbatim | |
1534 | (t val))) | |
6dd12ef2 CY |
1535 | |
1536 | ;;; Object Set macros | |
1537 | ;; | |
1538 | (defmacro oset (obj slot value) | |
1539 | "Set the value in OBJ for slot SLOT to VALUE. | |
1540 | SLOT is the slot name as specified in `defclass' or the tag created | |
1541 | with in the :initarg slot. VALUE can be any Lisp object." | |
1542 | `(eieio-oset ,obj (quote ,slot) ,value)) | |
1543 | ||
1544 | (defun eieio-oset (obj slot value) | |
a8f316ca | 1545 | "Do the work for the macro `oset'. |
6dd12ef2 CY |
1546 | Fills in OBJ's SLOT with VALUE." |
1547 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1548 | (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) | |
1549 | (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) | |
1550 | (if (not c) | |
1551 | ;; It might be missing because it is a :class allocated slot. | |
c7015153 | 1552 | ;; Let's check that info out. |
6dd12ef2 CY |
1553 | (if (setq c |
1554 | (eieio-class-slot-name-index (aref obj object-class) slot)) | |
1555 | ;; Oset that slot. | |
1556 | (progn | |
1557 | (eieio-validate-class-slot-value (object-class-fast obj) c value slot) | |
1558 | (aset (aref (class-v (aref obj object-class)) | |
1559 | class-class-allocation-values) | |
1560 | c value)) | |
1561 | ;; See oref for comment on `slot-missing' | |
1562 | (slot-missing obj slot 'oset value) | |
1563 | ;;(signal 'invalid-slot-name (list (object-name obj) slot)) | |
1564 | ) | |
1565 | (eieio-validate-slot-value (object-class-fast obj) c value slot) | |
1566 | (aset obj c value)))) | |
1567 | ||
1568 | (defmacro oset-default (class slot value) | |
1569 | "Set the default slot in CLASS for SLOT to VALUE. | |
1570 | The default value is usually set with the :initform tag during class | |
1571 | creation. This allows users to change the default behavior of classes | |
1572 | after they are created." | |
1573 | `(eieio-oset-default ,class (quote ,slot) ,value)) | |
1574 | ||
1575 | (defun eieio-oset-default (class slot value) | |
a8f316ca | 1576 | "Do the work for the macro `oset-default'. |
6dd12ef2 CY |
1577 | Fills in the default value in CLASS' in SLOT with VALUE." |
1578 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) | |
1579 | (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) | |
1580 | (let* ((scoped-class class) | |
1581 | (c (eieio-slot-name-index class nil slot))) | |
1582 | (if (not c) | |
1583 | ;; It might be missing because it is a :class allocated slot. | |
c7015153 | 1584 | ;; Let's check that info out. |
6dd12ef2 CY |
1585 | (if (setq c (eieio-class-slot-name-index class slot)) |
1586 | (progn | |
1587 | ;; Oref that slot. | |
1588 | (eieio-validate-class-slot-value class c value slot) | |
1589 | (aset (aref (class-v class) class-class-allocation-values) c | |
1590 | value)) | |
1591 | (signal 'invalid-slot-name (list (class-name class) slot))) | |
1592 | (eieio-validate-slot-value class c value slot) | |
1593 | ;; Set this into the storage for defaults. | |
1594 | (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) | |
1595 | value) | |
1596 | ;; Take the value, and put it into our cache object. | |
1597 | (eieio-oset (aref (class-v class) class-default-object-cache) | |
1598 | slot value) | |
1599 | ))) | |
1600 | ||
1601 | ;;; Handy CLOS macros | |
1602 | ;; | |
1603 | (defmacro with-slots (spec-list object &rest body) | |
1604 | "Bind SPEC-LIST lexically to slot values in OBJECT, and execute BODY. | |
1605 | This establishes a lexical environment for referring to the slots in | |
1606 | the instance named by the given slot-names as though they were | |
1607 | variables. Within such a context the value of the slot can be | |
1608 | specified by using its slot name, as if it were a lexically bound | |
1609 | variable. Both setf and setq can be used to set the value of the | |
1610 | slot. | |
1611 | ||
1612 | SPEC-LIST is of a form similar to `let'. For example: | |
1613 | ||
1614 | ((VAR1 SLOT1) | |
1615 | SLOT2 | |
1616 | SLOTN | |
1617 | (VARN+1 SLOTN+1)) | |
1618 | ||
1619 | Where each VAR is the local variable given to the associated | |
a8f316ca | 1620 | SLOT. A slot specified without a variable name is given a |
6dd12ef2 | 1621 | variable name of the same name as the slot." |
f291fe60 | 1622 | (declare (indent 2)) |
6dd12ef2 CY |
1623 | ;; Transform the spec-list into a symbol-macrolet spec-list. |
1624 | (let ((mappings (mapcar (lambda (entry) | |
1625 | (let ((var (if (listp entry) (car entry) entry)) | |
1626 | (slot (if (listp entry) (cadr entry) entry))) | |
1627 | (list var `(slot-value ,object ',slot)))) | |
1628 | spec-list))) | |
1629 | (append (list 'symbol-macrolet mappings) | |
1630 | body))) | |
6dd12ef2 CY |
1631 | \f |
1632 | ;;; Simple generators, and query functions. None of these would do | |
1633 | ;; well embedded into an object. | |
1634 | ;; | |
1635 | (defmacro object-class-fast (obj) "Return the class struct defining OBJ with no check." | |
1636 | `(aref ,obj object-class)) | |
1637 | ||
1638 | (defun class-name (class) "Return a Lisp like symbol name for CLASS." | |
1639 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) | |
1640 | ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, | |
1641 | ;; and I wanted a string. Arg! | |
1642 | (format "#<class %s>" (symbol-name class))) | |
1643 | ||
1644 | (defun object-name (obj &optional extra) | |
1645 | "Return a Lisp like symbol string for object OBJ. | |
1646 | If EXTRA, include that in the string returned to represent the symbol." | |
1647 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1648 | (format "#<%s %s%s>" (symbol-name (object-class-fast obj)) | |
1649 | (aref obj object-name) (or extra ""))) | |
1650 | ||
1651 | (defun object-name-string (obj) "Return a string which is OBJ's name." | |
1652 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1653 | (aref obj object-name)) | |
1654 | ||
1655 | (defun object-set-name-string (obj name) "Set the string which is OBJ's NAME." | |
1656 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1657 | (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name))) | |
1658 | (aset obj object-name name)) | |
1659 | ||
1660 | (defun object-class (obj) "Return the class struct defining OBJ." | |
1661 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1662 | (object-class-fast obj)) | |
1663 | (defalias 'class-of 'object-class) | |
1664 | ||
1665 | (defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." | |
1666 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1667 | (class-name (object-class-fast obj))) | |
1668 | ||
1669 | (defmacro class-parents-fast (class) "Return parent classes to CLASS with no check." | |
1670 | `(aref (class-v ,class) class-parent)) | |
1671 | ||
1672 | (defun class-parents (class) | |
1673 | "Return parent classes to CLASS. (overload of variable). | |
1674 | ||
1675 | The CLOS function `class-direct-superclasses' is aliased to this function." | |
1676 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) | |
1677 | (class-parents-fast class)) | |
1678 | ||
1679 | (defmacro class-children-fast (class) "Return child classes to CLASS with no check." | |
1680 | `(aref (class-v ,class) class-children)) | |
1681 | ||
1682 | (defun class-children (class) | |
9ffe3f52 | 1683 | "Return child classes to CLASS. |
6dd12ef2 CY |
1684 | |
1685 | The CLOS function `class-direct-subclasses' is aliased to this function." | |
1686 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) | |
1687 | (class-children-fast class)) | |
1688 | ||
a2930e43 EL |
1689 | (defun eieio-c3-candidate (class remaining-inputs) |
1690 | "Returns CLASS if it can go in the result now, otherwise nil" | |
1691 | ;; Ensure CLASS is not in any position but the first in any of the | |
1692 | ;; element lists of REMAINING-INPUTS. | |
1693 | (and (not (let ((found nil)) | |
1694 | (while (and remaining-inputs (not found)) | |
1695 | (setq found (member class (cdr (car remaining-inputs))) | |
1696 | remaining-inputs (cdr remaining-inputs))) | |
1697 | found)) | |
1698 | class)) | |
1699 | ||
1700 | (defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) | |
1701 | "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. | |
1702 | If a consistent order does not exist, signal an error." | |
1703 | (if (let ((tail remaining-inputs) | |
1704 | (found nil)) | |
1705 | (while (and tail (not found)) | |
1706 | (setq found (car tail) tail (cdr tail))) | |
1707 | (not found)) | |
1708 | ;; If all remaining inputs are empty lists, we are done. | |
1709 | (nreverse reversed-partial-result) | |
1710 | ;; Otherwise, we try to find the next element of the result. This | |
1711 | ;; is achieved by considering the first element of each | |
1712 | ;; (non-empty) input list and accepting a candidate if it is | |
1713 | ;; consistent with the rests of the input lists. | |
1714 | (let* ((found nil) | |
1715 | (tail remaining-inputs) | |
1716 | (next (progn | |
1717 | (while (and tail (not found)) | |
1718 | (setq found (and (car tail) | |
1719 | (eieio-c3-candidate (caar tail) | |
1720 | remaining-inputs)) | |
1721 | tail (cdr tail))) | |
1722 | found))) | |
1723 | (if next | |
1724 | ;; The graph is consistent so far, add NEXT to result and | |
1725 | ;; merge input lists, dropping NEXT from their heads where | |
1726 | ;; applicable. | |
1727 | (eieio-c3-merge-lists | |
1728 | (cons next reversed-partial-result) | |
1729 | (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) | |
1730 | remaining-inputs)) | |
1731 | ;; The graph is inconsistent, give up | |
1732 | (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) | |
1733 | ||
1734 | (defun eieio-class-precedence-dfs (class) | |
1735 | "Return all parents of CLASS in depth-first order." | |
1736 | (let* ((parents (class-parents-fast class)) | |
1737 | (classes (copy-sequence | |
1738 | (apply #'append | |
1739 | (list class) | |
1740 | (or | |
1741 | (mapcar | |
1742 | (lambda (parent) | |
1743 | (cons parent | |
1744 | (eieio-class-precedence-dfs parent))) | |
1745 | parents) | |
1746 | '((eieio-default-superclass)))))) | |
1747 | (tail classes)) | |
1748 | ;; Remove duplicates. | |
1749 | (while tail | |
1750 | (setcdr tail (delq (car tail) (cdr tail))) | |
1751 | (setq tail (cdr tail))) | |
1752 | classes)) | |
1753 | ||
1754 | (defun eieio-class-precedence-bfs (class) | |
1755 | "Return all parents of CLASS in breadth-first order." | |
1756 | (let ((result) | |
1757 | (queue (or (class-parents-fast class) | |
1758 | '(eieio-default-superclass)))) | |
1759 | (while queue | |
1760 | (let ((head (pop queue))) | |
1761 | (unless (member head result) | |
1762 | (push head result) | |
1763 | (unless (eq head 'eieio-default-superclass) | |
1764 | (setq queue (append queue (or (class-parents-fast head) | |
1765 | '(eieio-default-superclass)))))))) | |
1766 | (cons class (nreverse result))) | |
1767 | ) | |
1768 | ||
1769 | (defun eieio-class-precedence-c3 (class) | |
1770 | "Return all parents of CLASS in c3 order." | |
1771 | (let ((parents (class-parents-fast class))) | |
1772 | (eieio-c3-merge-lists | |
1773 | (list class) | |
1774 | (append | |
1775 | (or | |
1776 | (mapcar | |
1777 | (lambda (x) | |
1778 | (eieio-class-precedence-c3 x)) | |
1779 | parents) | |
1780 | '((eieio-default-superclass))) | |
1781 | (list parents)))) | |
1782 | ) | |
1783 | ||
1784 | (defun class-precedence-list (class) | |
1785 | "Return (transitively closed) list of parents of CLASS. | |
1786 | The order, in which the parents are returned depends on the | |
1787 | method invocation orders of the involved classes." | |
1788 | (if (or (null class) (eq class 'eieio-default-superclass)) | |
1789 | nil | |
1790 | (case (class-method-invocation-order class) | |
1791 | (:depth-first | |
1792 | (eieio-class-precedence-dfs class)) | |
1793 | (:breadth-first | |
1794 | (eieio-class-precedence-bfs class)) | |
1795 | (:c3 | |
1796 | (eieio-class-precedence-c3 class)))) | |
1797 | ) | |
1798 | ||
6dd12ef2 CY |
1799 | ;; Official CLOS functions. |
1800 | (defalias 'class-direct-superclasses 'class-parents) | |
1801 | (defalias 'class-direct-subclasses 'class-children) | |
1802 | ||
1803 | (defmacro class-parent-fast (class) "Return first parent class to CLASS with no check." | |
1804 | `(car (class-parents-fast ,class))) | |
1805 | ||
1806 | (defmacro class-parent (class) "Return first parent class to CLASS. (overload of variable)." | |
1807 | `(car (class-parents ,class))) | |
1808 | ||
1809 | (defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type CLASS with no error checking." | |
1810 | `(eq (aref ,obj object-class) ,class)) | |
1811 | ||
1812 | (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." | |
1813 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) | |
1814 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1815 | (same-class-fast-p obj class)) | |
1816 | ||
1817 | (defun object-of-class-p (obj class) | |
1818 | "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." | |
1819 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) | |
1820 | ;; class will be checked one layer down | |
1821 | (child-of-class-p (aref obj object-class) class)) | |
1822 | ;; Backwards compatibility | |
1823 | (defalias 'obj-of-class-p 'object-of-class-p) | |
1824 | ||
1825 | (defun child-of-class-p (child class) | |
a8f316ca | 1826 | "Return non-nil if CHILD class is a subclass of CLASS." |
6dd12ef2 CY |
1827 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) |
1828 | (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p child))) | |
1829 | (let ((p nil)) | |
1830 | (while (and child (not (eq child class))) | |
1831 | (setq p (append p (aref (class-v child) class-parent)) | |
1832 | child (car p) | |
1833 | p (cdr p))) | |
1834 | (if child t))) | |
1835 | ||
a2930e43 EL |
1836 | (defun object-slots (obj) |
1837 | "Return list of slots available in OBJ." | |
6dd12ef2 CY |
1838 | (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) |
1839 | (aref (class-v (object-class-fast obj)) class-public-a)) | |
1840 | ||
1841 | (defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." | |
1842 | (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) | |
1843 | (let ((ia (aref (class-v class) class-initarg-tuples)) | |
1844 | (f nil)) | |
1845 | (while (and ia (not f)) | |
1846 | (if (eq (cdr (car ia)) slot) | |
1847 | (setq f (car (car ia)))) | |
1848 | (setq ia (cdr ia))) | |
1849 | f)) | |
1850 | ||
1851 | ;;; CLOS queries into classes and slots | |
1852 | ;; | |
1853 | (defun slot-boundp (object slot) | |
a8f316ca | 1854 | "Return non-nil if OBJECT's SLOT is bound. |
6dd12ef2 CY |
1855 | Setting a slot's value makes it bound. Calling `slot-makeunbound' will |
1856 | make a slot unbound. | |
1857 | OBJECT can be an instance or a class." | |
1858 | ;; Skip typechecking while retrieving this value. | |
1859 | (let ((eieio-skip-typecheck t)) | |
1860 | ;; Return nil if the magic symbol is in there. | |
9869b3ae SM |
1861 | (not (eq (cond |
1862 | ((eieio-object-p object) (eieio-oref object slot)) | |
1863 | ((class-p object) (eieio-oref-default object slot)) | |
1864 | (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) | |
1865 | eieio-unbound)))) | |
6dd12ef2 CY |
1866 | |
1867 | (defun slot-makeunbound (object slot) | |
1868 | "In OBJECT, make SLOT unbound." | |
1869 | (eieio-oset object slot eieio-unbound)) | |
1870 | ||
1871 | (defun slot-exists-p (object-or-class slot) | |
a8f316ca | 1872 | "Return non-nil if OBJECT-OR-CLASS has SLOT." |
6dd12ef2 CY |
1873 | (let ((cv (class-v (cond ((eieio-object-p object-or-class) |
1874 | (object-class object-or-class)) | |
1875 | ((class-p object-or-class) | |
1876 | object-or-class)) | |
1877 | ))) | |
1878 | (or (memq slot (aref cv class-public-a)) | |
1879 | (memq slot (aref cv class-class-allocation-a))) | |
1880 | )) | |
1881 | ||
1882 | (defun find-class (symbol &optional errorp) | |
1883 | "Return the class that SYMBOL represents. | |
1884 | If there is no class, nil is returned if ERRORP is nil. | |
1885 | If ERRORP is non-nil, `wrong-argument-type' is signaled." | |
1886 | (if (not (class-p symbol)) | |
1887 | (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) | |
1888 | nil) | |
1889 | (class-v symbol))) | |
1890 | ||
1891 | ;;; Slightly more complex utility functions for objects | |
1892 | ;; | |
1893 | (defun object-assoc (key slot list) | |
1894 | "Return an object if KEY is `equal' to SLOT's value of an object in LIST. | |
a8f316ca | 1895 | LIST is a list of objects whose slots are searched. |
6dd12ef2 CY |
1896 | Objects in LIST do not need to have a slot named SLOT, nor does |
1897 | SLOT need to be bound. If these errors occur, those objects will | |
1898 | be ignored." | |
1899 | (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) | |
1900 | (while (and list (not (condition-case nil | |
1901 | ;; This prevents errors for missing slots. | |
1902 | (equal key (eieio-oref (car list) slot)) | |
1903 | (error nil)))) | |
1904 | (setq list (cdr list))) | |
1905 | (car list)) | |
1906 | ||
1907 | (defun object-assoc-list (slot list) | |
1908 | "Return an association list with the contents of SLOT as the key element. | |
1909 | LIST must be a list of objects with SLOT in it. | |
1910 | This is useful when you need to do completing read on an object group." | |
1911 | (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) | |
1912 | (let ((assoclist nil)) | |
1913 | (while list | |
1914 | (setq assoclist (cons (cons (eieio-oref (car list) slot) | |
1915 | (car list)) | |
1916 | assoclist)) | |
1917 | (setq list (cdr list))) | |
1918 | (nreverse assoclist))) | |
1919 | ||
1920 | (defun object-assoc-list-safe (slot list) | |
1921 | "Return an association list with the contents of SLOT as the key element. | |
1922 | LIST must be a list of objects, but those objects do not need to have | |
1923 | SLOT in it. If it does not, then that element is left out of the association | |
1924 | list." | |
1925 | (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list))) | |
1926 | (let ((assoclist nil)) | |
1927 | (while list | |
1928 | (if (slot-exists-p (car list) slot) | |
1929 | (setq assoclist (cons (cons (eieio-oref (car list) slot) | |
1930 | (car list)) | |
1931 | assoclist))) | |
1932 | (setq list (cdr list))) | |
1933 | (nreverse assoclist))) | |
1934 | ||
1935 | (defun object-add-to-list (object slot item &optional append) | |
1936 | "In OBJECT's SLOT, add ITEM to the list of elements. | |
1937 | Optional argument APPEND indicates we need to append to the list. | |
1938 | If ITEM already exists in the list in SLOT, then it is not added. | |
1939 | Comparison is done with `equal' through the `member' function call. | |
1940 | If SLOT is unbound, bind it to the list containing ITEM." | |
1941 | (let (ov) | |
1942 | ;; Find the originating list. | |
1943 | (if (not (slot-boundp object slot)) | |
1944 | (setq ov (list item)) | |
1945 | (setq ov (eieio-oref object slot)) | |
1946 | ;; turn it into a list. | |
1947 | (unless (listp ov) | |
1948 | (setq ov (list ov))) | |
1949 | ;; Do the combination | |
1950 | (if (not (member item ov)) | |
1951 | (setq ov | |
1952 | (if append | |
1953 | (append ov (list item)) | |
1954 | (cons item ov))))) | |
1955 | ;; Set back into the slot. | |
1956 | (eieio-oset object slot ov))) | |
1957 | ||
1958 | (defun object-remove-from-list (object slot item) | |
1959 | "In OBJECT's SLOT, remove occurrences of ITEM. | |
a8f316ca | 1960 | Deletion is done with `delete', which deletes by side effect, |
6dd12ef2 CY |
1961 | and comparisons are done with `equal'. |
1962 | If SLOT is unbound, do nothing." | |
1963 | (if (not (slot-boundp object slot)) | |
1964 | nil | |
1965 | (eieio-oset object slot (delete item (eieio-oref object slot))))) | |
1966 | \f | |
1967 | ;;; EIEIO internal search functions | |
1968 | ;; | |
1969 | (defun eieio-slot-originating-class-p (start-class slot) | |
a8f316ca | 1970 | "Return non-nil if START-CLASS is the first class to define SLOT. |
6dd12ef2 CY |
1971 | This is for testing if `scoped-class' is the class that defines SLOT |
1972 | so that we can protect private slots." | |
1973 | (let ((par (class-parents start-class)) | |
1974 | (ret t)) | |
1975 | (if (not par) | |
1976 | t | |
1977 | (while (and par ret) | |
1978 | (if (intern-soft (symbol-name slot) | |
1979 | (aref (class-v (car par)) | |
1980 | class-symbol-obarray)) | |
1981 | (setq ret nil)) | |
1982 | (setq par (cdr par))) | |
1983 | ret))) | |
1984 | ||
1985 | (defun eieio-slot-name-index (class obj slot) | |
1986 | "In CLASS for OBJ find the index of the named SLOT. | |
1987 | The slot is a symbol which is installed in CLASS by the `defclass' | |
1988 | call. OBJ can be nil, but if it is an object, and the slot in question | |
a8f316ca | 1989 | is protected, access will be allowed if OBJ is a child of the currently |
6dd12ef2 CY |
1990 | `scoped-class'. |
1991 | If SLOT is the value created with :initarg instead, | |
1992 | reverse-lookup that name, and recurse with the associated slot value." | |
1993 | ;; Removed checks to outside this call | |
1994 | (let* ((fsym (intern-soft (symbol-name slot) | |
1995 | (aref (class-v class) | |
1996 | class-symbol-obarray))) | |
1997 | (fsi (if (symbolp fsym) (symbol-value fsym) nil))) | |
1998 | (if (integerp fsi) | |
1999 | (cond | |
2000 | ((not (get fsym 'protection)) | |
2001 | (+ 3 fsi)) | |
2002 | ((and (eq (get fsym 'protection) 'protected) | |
2003 | scoped-class | |
2004 | (or (child-of-class-p class scoped-class) | |
2005 | (and (eieio-object-p obj) | |
2006 | (child-of-class-p class (object-class obj))))) | |
2007 | (+ 3 fsi)) | |
2008 | ((and (eq (get fsym 'protection) 'private) | |
2009 | (or (and scoped-class | |
2010 | (eieio-slot-originating-class-p scoped-class slot)) | |
2011 | eieio-initializing-object)) | |
2012 | (+ 3 fsi)) | |
2013 | (t nil)) | |
2014 | (let ((fn (eieio-initarg-to-attribute class slot))) | |
2015 | (if fn (eieio-slot-name-index class obj fn) nil))))) | |
2016 | ||
2017 | (defun eieio-class-slot-name-index (class slot) | |
2018 | "In CLASS find the index of the named SLOT. | |
2019 | The slot is a symbol which is installed in CLASS by the `defclass' | |
2020 | call. If SLOT is the value created with :initarg instead, | |
2021 | reverse-lookup that name, and recurse with the associated slot value." | |
2022 | ;; This will happen less often, and with fewer slots. Do this the | |
2023 | ;; storage cheap way. | |
2024 | (let* ((a (aref (class-v class) class-class-allocation-a)) | |
2025 | (l1 (length a)) | |
2026 | (af (memq slot a)) | |
2027 | (l2 (length af))) | |
2028 | ;; Slot # is length of the total list, minus the remaining list of | |
2029 | ;; the found slot. | |
2030 | (if af (- l1 l2)))) | |
2031 | \f | |
2032 | ;;; CLOS generics internal function handling | |
2033 | ;; | |
2034 | (defvar eieio-generic-call-methodname nil | |
2035 | "When using `call-next-method', provides a context on how to do it.") | |
2036 | (defvar eieio-generic-call-arglst nil | |
2037 | "When using `call-next-method', provides a context for parameters.") | |
2038 | (defvar eieio-generic-call-key nil | |
2039 | "When using `call-next-method', provides a context for the current key. | |
2040 | Keys are a number representing :before, :primary, and :after methods.") | |
2041 | (defvar eieio-generic-call-next-method-list nil | |
2042 | "When executing a PRIMARY or STATIC method, track the 'next-method'. | |
2043 | During executions, the list is first generated, then as each next method | |
2044 | is called, the next method is popped off the stack.") | |
2045 | ||
2046 | (defvar eieio-pre-method-execution-hooks nil | |
2047 | "*Hooks run just before a method is executed. | |
a8f316ca | 2048 | The hook function must accept one argument, the list of forms |
6dd12ef2 CY |
2049 | about to be executed.") |
2050 | ||
2051 | (defun eieio-generic-call (method args) | |
2052 | "Call METHOD with ARGS. | |
2053 | ARGS provides the context on which implementation to use. | |
2054 | This should only be called from a generic function." | |
2055 | ;; We must expand our arguments first as they are always | |
2056 | ;; passed in as quoted symbols | |
2057 | (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) | |
2058 | (eieio-generic-call-methodname method) | |
2059 | (eieio-generic-call-arglst args) | |
2060 | (firstarg nil) | |
2061 | (primarymethodlist nil)) | |
2062 | ;; get a copy | |
2063 | (setq newargs args | |
2064 | firstarg (car newargs)) | |
2065 | ;; Is the class passed in autoloaded? | |
2066 | ;; Since class names are also constructors, they can be autoloaded | |
2067 | ;; via the autoload command. Check for this, and load them in. | |
2068 | ;; It's ok if it doesn't turn out to be a class. Probably want that | |
2069 | ;; function loaded anyway. | |
2070 | (if (and (symbolp firstarg) | |
2071 | (fboundp firstarg) | |
2072 | (listp (symbol-function firstarg)) | |
2073 | (eq 'autoload (car (symbol-function firstarg)))) | |
2074 | (load (nth 1 (symbol-function firstarg)))) | |
2075 | ;; Determine the class to use. | |
2076 | (cond ((eieio-object-p firstarg) | |
2077 | (setq mclass (object-class-fast firstarg))) | |
2078 | ((class-p firstarg) | |
2079 | (setq mclass firstarg)) | |
2080 | ) | |
2081 | ;; Make sure the class is a valid class | |
2082 | ;; mclass can be nil (meaning a generic for should be used. | |
2083 | ;; mclass cannot have a value that is not a class, however. | |
2084 | (when (and (not (null mclass)) (not (class-p mclass))) | |
2085 | (error "Cannot dispatch method %S on class %S" | |
2086 | method mclass) | |
2087 | ) | |
2088 | ;; Now create a list in reverse order of all the calls we have | |
2089 | ;; make in order to successfully do this right. Rules: | |
2090 | ;; 1) Only call generics if scoped-class is not defined | |
2091 | ;; This prevents multiple calls in the case of recursion | |
2092 | ;; 2) Only call static if this is a static method. | |
2093 | ;; 3) Only call specifics if the definition allows for them. | |
2094 | ;; 4) Call in order based on :before, :primary, and :after | |
2095 | (when (eieio-object-p firstarg) | |
2096 | ;; Non-static calls do all this stuff. | |
2097 | ||
2098 | ;; :after methods | |
2099 | (setq tlambdas | |
2100 | (if mclass | |
2101 | (eieiomt-method-list method method-after mclass) | |
2102 | (list (eieio-generic-form method method-after nil))) | |
2103 | ;;(or (and mclass (eieio-generic-form method method-after mclass)) | |
2104 | ;; (eieio-generic-form method method-after nil)) | |
2105 | ) | |
2106 | (setq lambdas (append tlambdas lambdas) | |
2107 | keys (append (make-list (length tlambdas) method-after) keys)) | |
2108 | ||
2109 | ;; :primary methods | |
2110 | (setq tlambdas | |
2111 | (or (and mclass (eieio-generic-form method method-primary mclass)) | |
2112 | (eieio-generic-form method method-primary nil))) | |
2113 | (when tlambdas | |
2114 | (setq lambdas (cons tlambdas lambdas) | |
2115 | keys (cons method-primary keys) | |
2116 | primarymethodlist | |
2117 | (eieiomt-method-list method method-primary mclass))) | |
2118 | ||
2119 | ;; :before methods | |
2120 | (setq tlambdas | |
2121 | (if mclass | |
2122 | (eieiomt-method-list method method-before mclass) | |
2123 | (list (eieio-generic-form method method-before nil))) | |
2124 | ;;(or (and mclass (eieio-generic-form method method-before mclass)) | |
2125 | ;; (eieio-generic-form method method-before nil)) | |
2126 | ) | |
2127 | (setq lambdas (append tlambdas lambdas) | |
2128 | keys (append (make-list (length tlambdas) method-before) keys)) | |
2129 | ) | |
2130 | ||
a2930e43 EL |
2131 | (if mclass |
2132 | ;; For the case of a class, | |
2133 | ;; if there were no methods found, then there could be :static methods. | |
2134 | (when (not lambdas) | |
2135 | (setq tlambdas | |
2136 | (eieio-generic-form method method-static mclass)) | |
2137 | (setq lambdas (cons tlambdas lambdas) | |
2138 | keys (cons method-static keys) | |
2139 | primarymethodlist ;; Re-use even with bad name here | |
2140 | (eieiomt-method-list method method-static mclass))) | |
2141 | ;; For the case of no class (ie - mclass == nil) then there may | |
2142 | ;; be a primary method. | |
6dd12ef2 | 2143 | (setq tlambdas |
a2930e43 EL |
2144 | (eieio-generic-form method method-primary nil)) |
2145 | (when tlambdas | |
2146 | (setq lambdas (cons tlambdas lambdas) | |
2147 | keys (cons method-primary keys) | |
2148 | primarymethodlist | |
2149 | (eieiomt-method-list method method-primary nil))) | |
2150 | ) | |
6dd12ef2 CY |
2151 | |
2152 | (run-hook-with-args 'eieio-pre-method-execution-hooks | |
2153 | primarymethodlist) | |
2154 | ||
db9e401b | 2155 | ;; Now loop through all occurrences forms which we must execute |
6dd12ef2 CY |
2156 | ;; (which are happily sorted now) and execute them all! |
2157 | (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) | |
2158 | (while lambdas | |
2159 | (if (car lambdas) | |
2160 | (let* ((scoped-class (cdr (car lambdas))) | |
2161 | (eieio-generic-call-key (car keys)) | |
2162 | (has-return-val | |
2163 | (or (= eieio-generic-call-key method-primary) | |
2164 | (= eieio-generic-call-key method-static))) | |
2165 | (eieio-generic-call-next-method-list | |
2166 | ;; Use the cdr, as the first element is the fcn | |
2167 | ;; we are calling right now. | |
2168 | (when has-return-val (cdr primarymethodlist))) | |
2169 | ) | |
2170 | (setq found t) | |
2171 | ;;(setq rval (apply (car (car lambdas)) newargs)) | |
2172 | (setq lastval (apply (car (car lambdas)) newargs)) | |
2173 | (when has-return-val | |
2174 | (setq rval lastval | |
2175 | rvalever t)) | |
2176 | )) | |
2177 | (setq lambdas (cdr lambdas) | |
2178 | keys (cdr keys))) | |
2179 | (if (not found) | |
2180 | (if (eieio-object-p (car args)) | |
2181 | (setq rval (apply 'no-applicable-method (car args) method args) | |
2182 | rvalever t) | |
2183 | (signal | |
2184 | 'no-method-definition | |
2185 | (list method args)))) | |
2186 | ;; Right Here... it could be that lastval is returned when | |
2187 | ;; rvalever is nil. Is that right? | |
2188 | rval))) | |
2189 | ||
2190 | (defun eieio-generic-call-primary-only (method args) | |
2191 | "Call METHOD with ARGS for methods with only :PRIMARY implementations. | |
2192 | ARGS provides the context on which implementation to use. | |
2193 | This should only be called from a generic function. | |
2194 | ||
2195 | This method is like `eieio-generic-call', but only | |
2196 | implementations in the :PRIMARY slot are queried. After many | |
2197 | years of use, it appears that over 90% of methods in use | |
2198 | have :PRIMARY implementations only. We can therefore optimize | |
2199 | for this common case to improve performance." | |
2200 | ;; We must expand our arguments first as they are always | |
2201 | ;; passed in as quoted symbols | |
2202 | (let ((newargs nil) (mclass nil) (lambdas nil) | |
2203 | (eieio-generic-call-methodname method) | |
2204 | (eieio-generic-call-arglst args) | |
2205 | (firstarg nil) | |
2206 | (primarymethodlist nil) | |
2207 | ) | |
2208 | ;; get a copy | |
2209 | (setq newargs args | |
2210 | firstarg (car newargs)) | |
2211 | ||
2212 | ;; Determine the class to use. | |
2213 | (cond ((eieio-object-p firstarg) | |
2214 | (setq mclass (object-class-fast firstarg))) | |
2215 | ((not firstarg) | |
2216 | (error "Method %s called on nil" method)) | |
2217 | ((not (eieio-object-p firstarg)) | |
2218 | (error "Primary-only method %s called on something not an object" method)) | |
2219 | (t | |
2220 | (error "EIEIO Error: Improperly classified method %s as primary only" | |
2221 | method) | |
2222 | )) | |
2223 | ;; Make sure the class is a valid class | |
2224 | ;; mclass can be nil (meaning a generic for should be used. | |
2225 | ;; mclass cannot have a value that is not a class, however. | |
2226 | (when (null mclass) | |
2227 | (error "Cannot dispatch method %S on class %S" method mclass) | |
2228 | ) | |
2229 | ||
2230 | ;; :primary methods | |
2231 | (setq lambdas (eieio-generic-form method method-primary mclass)) | |
2232 | (setq primarymethodlist ;; Re-use even with bad name here | |
2233 | (eieiomt-method-list method method-primary mclass)) | |
2234 | ||
db9e401b | 2235 | ;; Now loop through all occurrences forms which we must execute |
6dd12ef2 CY |
2236 | ;; (which are happily sorted now) and execute them all! |
2237 | (let* ((rval nil) (lastval nil) (rvalever nil) | |
2238 | (scoped-class (cdr lambdas)) | |
2239 | (eieio-generic-call-key method-primary) | |
2240 | ;; Use the cdr, as the first element is the fcn | |
2241 | ;; we are calling right now. | |
2242 | (eieio-generic-call-next-method-list (cdr primarymethodlist)) | |
2243 | ) | |
2244 | ||
2245 | (if (or (not lambdas) (not (car lambdas))) | |
2246 | ||
2247 | ;; No methods found for this impl... | |
2248 | (if (eieio-object-p (car args)) | |
2249 | (setq rval (apply 'no-applicable-method (car args) method args) | |
2250 | rvalever t) | |
2251 | (signal | |
2252 | 'no-method-definition | |
2253 | (list method args))) | |
2254 | ||
2255 | ;; Do the regular implementation here. | |
2256 | ||
2257 | (run-hook-with-args 'eieio-pre-method-execution-hooks | |
2258 | lambdas) | |
2259 | ||
2260 | (setq lastval (apply (car lambdas) newargs)) | |
2261 | (setq rval lastval | |
2262 | rvalever t) | |
2263 | ) | |
2264 | ||
2265 | ;; Right Here... it could be that lastval is returned when | |
2266 | ;; rvalever is nil. Is that right? | |
2267 | rval))) | |
2268 | ||
2269 | (defun eieiomt-method-list (method key class) | |
2270 | "Return an alist list of methods lambdas. | |
2271 | METHOD is the method name. | |
2272 | KEY represents either :before, or :after methods. | |
2273 | CLASS is the starting class to search from in the method tree. | |
2274 | If CLASS is nil, then an empty list of methods should be returned." | |
2275 | ;; Note: eieiomt - the MT means MethodTree. See more comments below | |
2276 | ;; for the rest of the eieiomt methods. | |
a2930e43 EL |
2277 | |
2278 | ;; Collect lambda expressions stored for the class and its parent | |
2279 | ;; classes. | |
2280 | (let (lambdas) | |
2281 | (dolist (ancestor (class-precedence-list class)) | |
2282 | ;; Lookup the form to use for the PRIMARY object for the next level | |
2283 | (let ((tmpl (eieio-generic-form method key ancestor))) | |
2284 | (when (and tmpl | |
2285 | (or (not lambdas) | |
2286 | ;; This prevents duplicates coming out of the | |
2287 | ;; class method optimizer. Perhaps we should | |
2288 | ;; just not optimize before/afters? | |
2289 | (not (member tmpl lambdas)))) | |
2290 | (push tmpl lambdas)))) | |
2291 | ||
2292 | ;; Return collected lambda. For :after methods, return in current | |
2293 | ;; order (most general class last); Otherwise, reverse order. | |
6dd12ef2 CY |
2294 | (if (eq key method-after) |
2295 | lambdas | |
2296 | (nreverse lambdas)))) | |
2297 | ||
2298 | (defun next-method-p () | |
a8f316ca | 2299 | "Return non-nil if there is a next method. |
6dd12ef2 CY |
2300 | Returns a list of lambda expressions which is the `next-method' |
2301 | order." | |
2302 | eieio-generic-call-next-method-list) | |
2303 | ||
2304 | (defun call-next-method (&rest replacement-args) | |
2305 | "Call the superclass method from a subclass method. | |
2306 | The superclass method is specified in the current method list, | |
2307 | and is called the next method. | |
2308 | ||
2309 | If REPLACEMENT-ARGS is non-nil, then use them instead of | |
2310 | `eieio-generic-call-arglst'. The generic arg list are the | |
2311 | arguments passed in at the top level. | |
2312 | ||
2313 | Use `next-method-p' to find out if there is a next method to call." | |
2314 | (if (not scoped-class) | |
a8f316ca | 2315 | (error "`call-next-method' not called within a class specific method")) |
6dd12ef2 CY |
2316 | (if (and (/= eieio-generic-call-key method-primary) |
2317 | (/= eieio-generic-call-key method-static)) | |
2318 | (error "Cannot `call-next-method' except in :primary or :static methods") | |
2319 | ) | |
2320 | (let ((newargs (or replacement-args eieio-generic-call-arglst)) | |
2321 | (next (car eieio-generic-call-next-method-list)) | |
2322 | ) | |
2323 | (if (or (not next) (not (car next))) | |
2324 | (apply 'no-next-method (car newargs) (cdr newargs)) | |
2325 | (let* ((eieio-generic-call-next-method-list | |
2326 | (cdr eieio-generic-call-next-method-list)) | |
a2930e43 | 2327 | (eieio-generic-call-arglst newargs) |
6dd12ef2 CY |
2328 | (scoped-class (cdr next)) |
2329 | (fcn (car next)) | |
2330 | ) | |
2331 | (apply fcn newargs) | |
2332 | )))) | |
2333 | \f | |
2334 | ;;; | |
2335 | ;; eieio-method-tree : eieiomt- | |
2336 | ;; | |
2337 | ;; Stored as eieio-method-tree in property list of a generic method | |
2338 | ;; | |
2339 | ;; (eieio-method-tree . [BEFORE PRIMARY AFTER | |
2340 | ;; genericBEFORE genericPRIMARY genericAFTER]) | |
2341 | ;; and | |
2342 | ;; (eieio-method-obarray . [BEFORE PRIMARY AFTER | |
2343 | ;; genericBEFORE genericPRIMARY genericAFTER]) | |
2344 | ;; where the association is a vector. | |
2345 | ;; (aref 0 -- all static methods. | |
2346 | ;; (aref 1 -- all methods classified as :before | |
2347 | ;; (aref 2 -- all methods classified as :primary | |
2348 | ;; (aref 3 -- all methods classified as :after | |
2349 | ;; (aref 4 -- a generic classified as :before | |
2350 | ;; (aref 5 -- a generic classified as :primary | |
2351 | ;; (aref 6 -- a generic classified as :after | |
2352 | ;; | |
2353 | (defvar eieiomt-optimizing-obarray nil | |
2354 | "While mapping atoms, this contain the obarray being optimized.") | |
2355 | ||
2356 | (defun eieiomt-install (method-name) | |
2357 | "Install the method tree, and obarray onto METHOD-NAME. | |
2358 | Do not do the work if they already exist." | |
2359 | (let ((emtv (get method-name 'eieio-method-tree)) | |
2360 | (emto (get method-name 'eieio-method-obarray))) | |
2361 | (if (or (not emtv) (not emto)) | |
2362 | (progn | |
2363 | (setq emtv (put method-name 'eieio-method-tree | |
2364 | (make-vector method-num-slots nil)) | |
2365 | emto (put method-name 'eieio-method-obarray | |
2366 | (make-vector method-num-slots nil))) | |
2367 | (aset emto 0 (make-vector 11 0)) | |
2368 | (aset emto 1 (make-vector 11 0)) | |
2369 | (aset emto 2 (make-vector 41 0)) | |
2370 | (aset emto 3 (make-vector 11 0)) | |
2371 | )))) | |
2372 | ||
2373 | (defun eieiomt-add (method-name method key class) | |
2374 | "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. | |
2375 | METHOD-NAME is the name created by a call to `defgeneric'. | |
2376 | METHOD are the forms for a given implementation. | |
2377 | KEY is an integer (see comment in eieio.el near this function) which | |
2378 | is associated with the :static :before :primary and :after tags. | |
2379 | It also indicates if CLASS is defined or not. | |
2380 | CLASS is the class this method is associated with." | |
2381 | (if (or (> key method-num-slots) (< key 0)) | |
a8f316ca | 2382 | (error "eieiomt-add: method key error!")) |
6dd12ef2 CY |
2383 | (let ((emtv (get method-name 'eieio-method-tree)) |
2384 | (emto (get method-name 'eieio-method-obarray))) | |
2385 | ;; Make sure the method tables are available. | |
2386 | (if (or (not emtv) (not emto)) | |
2387 | (error "Programmer error: eieiomt-add")) | |
2388 | ;; only add new cells on if it doesn't already exist! | |
2389 | (if (assq class (aref emtv key)) | |
2390 | (setcdr (assq class (aref emtv key)) method) | |
2391 | (aset emtv key (cons (cons class method) (aref emtv key)))) | |
2392 | ;; Add function definition into newly created symbol, and store | |
2393 | ;; said symbol in the correct obarray, otherwise use the | |
2394 | ;; other array to keep this stuff | |
2395 | (if (< key method-num-lists) | |
2396 | (let ((nsym (intern (symbol-name class) (aref emto key)))) | |
2397 | (fset nsym method))) | |
2398 | ;; Now optimize the entire obarray | |
2399 | (if (< key method-num-lists) | |
2400 | (let ((eieiomt-optimizing-obarray (aref emto key))) | |
2401 | ;; @todo - Is this overkill? Should we just clear the symbol? | |
2402 | (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) | |
2403 | )) | |
2404 | ||
2405 | (defun eieiomt-next (class) | |
2406 | "Return the next parent class for CLASS. | |
a8f316ca JB |
2407 | If CLASS is a superclass, return variable `eieio-default-superclass'. |
2408 | If CLASS is variable `eieio-default-superclass' then return nil. | |
2409 | This is different from function `class-parent' as class parent returns | |
2410 | nil for superclasses. This function performs no type checking!" | |
6dd12ef2 CY |
2411 | ;; No type-checking because all calls are made from functions which |
2412 | ;; are safe and do checking for us. | |
2413 | (or (class-parents-fast class) | |
2414 | (if (eq class 'eieio-default-superclass) | |
2415 | nil | |
2416 | '(eieio-default-superclass)))) | |
2417 | ||
2418 | (defun eieiomt-sym-optimize (s) | |
2419 | "Find the next class above S which has a function body for the optimizer." | |
a2930e43 EL |
2420 | ;; Set the value to nil in case there is no nearest cell. |
2421 | (set s nil) | |
2422 | ;; Find the nearest cell that has a function body. If we find one, | |
2423 | ;; we replace the nil from above. | |
2424 | (let ((external-symbol (intern-soft (symbol-name s)))) | |
2425 | (catch 'done | |
2426 | (dolist (ancestor (rest (class-precedence-list external-symbol))) | |
2427 | (let ((ov (intern-soft (symbol-name ancestor) | |
2428 | eieiomt-optimizing-obarray))) | |
2429 | (when (fboundp ov) | |
2430 | (set s ov) ;; store ov as our next symbol | |
2431 | (throw 'done ancestor))))))) | |
6dd12ef2 CY |
2432 | |
2433 | (defun eieio-generic-form (method key class) | |
2434 | "Return the lambda form belonging to METHOD using KEY based upon CLASS. | |
a8f316ca JB |
2435 | If CLASS is not a class then use `generic' instead. If class has |
2436 | no form, but has a parent class, then trace to that parent class. | |
2437 | The first time a form is requested from a symbol, an optimized path | |
db9e401b | 2438 | is memorized for faster future use." |
6dd12ef2 | 2439 | (let ((emto (aref (get method 'eieio-method-obarray) |
a2930e43 | 2440 | (if class key (eieio-specialized-key-to-generic-key key))))) |
6dd12ef2 CY |
2441 | (if (class-p class) |
2442 | ;; 1) find our symbol | |
2443 | (let ((cs (intern-soft (symbol-name class) emto))) | |
2444 | (if (not cs) | |
2445 | ;; 2) If there isn't one, then make one. | |
2446 | ;; This can be slow since it only occurs once | |
2447 | (progn | |
2448 | (setq cs (intern (symbol-name class) emto)) | |
a8f316ca | 2449 | ;; 2.1) Cache its nearest neighbor with a quick optimize |
6dd12ef2 CY |
2450 | ;; which should only occur once for this call ever |
2451 | (let ((eieiomt-optimizing-obarray emto)) | |
2452 | (eieiomt-sym-optimize cs)))) | |
2453 | ;; 3) If it's bound return this one. | |
2454 | (if (fboundp cs) | |
2455 | (cons cs (aref (class-v class) class-symbol)) | |
2456 | ;; 4) If it's not bound then this variable knows something | |
2457 | (if (symbol-value cs) | |
2458 | (progn | |
a8f316ca | 2459 | ;; 4.1) This symbol holds the next class in its value |
6dd12ef2 CY |
2460 | (setq class (symbol-value cs) |
2461 | cs (intern-soft (symbol-name class) emto)) | |
2462 | ;; 4.2) The optimizer should always have chosen a | |
2463 | ;; function-symbol | |
2464 | ;;(if (fboundp cs) | |
2465 | (cons cs (aref (class-v (intern (symbol-name class))) | |
2466 | class-symbol)) | |
2467 | ;;(error "EIEIO optimizer: erratic data loss!")) | |
2468 | ) | |
2469 | ;; There never will be a funcall... | |
2470 | nil))) | |
2471 | ;; for a generic call, what is a list, is the function body we want. | |
2472 | (let ((emtl (aref (get method 'eieio-method-tree) | |
a2930e43 | 2473 | (if class key (eieio-specialized-key-to-generic-key key))))) |
6dd12ef2 CY |
2474 | (if emtl |
2475 | ;; The car of EMTL is supposed to be a class, which in this | |
2476 | ;; case is nil, so skip it. | |
2477 | (cons (cdr (car emtl)) nil) | |
2478 | nil))))) | |
2479 | ||
2480 | ;;; | |
2481 | ;; Way to assign slots based on a list. Used for constructors, or | |
2482 | ;; even resetting an object at run-time | |
2483 | ;; | |
2484 | (defun eieio-set-defaults (obj &optional set-all) | |
2485 | "Take object OBJ, and reset all slots to their defaults. | |
2486 | If SET-ALL is non-nil, then when a default is nil, that value is | |
2487 | reset. If SET-ALL is nil, the slots are only reset if the default is | |
2488 | not nil." | |
2489 | (let ((scoped-class (aref obj object-class)) | |
2490 | (eieio-initializing-object t) | |
2491 | (pub (aref (class-v (aref obj object-class)) class-public-a))) | |
2492 | (while pub | |
2493 | (let ((df (eieio-oref-default obj (car pub)))) | |
2494 | (if (or df set-all) | |
2495 | (eieio-oset obj (car pub) df))) | |
2496 | (setq pub (cdr pub))))) | |
2497 | ||
2498 | (defun eieio-initarg-to-attribute (class initarg) | |
2499 | "For CLASS, convert INITARG to the actual attribute name. | |
2500 | If there is no translation, pass it in directly (so we can cheat if | |
a8f316ca | 2501 | need be... May remove that later...)" |
6dd12ef2 CY |
2502 | (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples)))) |
2503 | (if tuple | |
2504 | (cdr tuple) | |
2505 | nil))) | |
2506 | ||
2507 | (defun eieio-attribute-to-initarg (class attribute) | |
2508 | "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. | |
2509 | This is usually a symbol that starts with `:'." | |
2510 | (let ((tuple (rassoc attribute (aref (class-v class) class-initarg-tuples)))) | |
2511 | (if tuple | |
2512 | (car tuple) | |
2513 | nil))) | |
2514 | ||
2515 | \f | |
2516 | ;;; Here are some special types of errors | |
2517 | ;; | |
2518 | (intern "no-method-definition") | |
2519 | (put 'no-method-definition 'error-conditions '(no-method-definition error)) | |
2520 | (put 'no-method-definition 'error-message "No method definition") | |
2521 | ||
2522 | (intern "no-next-method") | |
2523 | (put 'no-next-method 'error-conditions '(no-next-method error)) | |
2524 | (put 'no-next-method 'error-message "No next method") | |
2525 | ||
2526 | (intern "invalid-slot-name") | |
2527 | (put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) | |
2528 | (put 'invalid-slot-name 'error-message "Invalid slot name") | |
2529 | ||
2530 | (intern "invalid-slot-type") | |
2531 | (put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) | |
2532 | (put 'invalid-slot-type 'error-message "Invalid slot type") | |
2533 | ||
2534 | (intern "unbound-slot") | |
2535 | (put 'unbound-slot 'error-conditions '(unbound-slot error nil)) | |
2536 | (put 'unbound-slot 'error-message "Unbound slot") | |
2537 | ||
a2930e43 EL |
2538 | (intern "inconsistent-class-hierarchy") |
2539 | (put 'inconsistent-class-hierarchy 'error-conditions | |
2540 | '(inconsistent-class-hierarchy error nil)) | |
2541 | (put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") | |
2542 | ||
6dd12ef2 CY |
2543 | ;;; Here are some CLOS items that need the CL package |
2544 | ;; | |
2545 | ||
2546 | (defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store)) | |
2547 | (defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store)) | |
2548 | ||
2549 | ;; The below setf method was written by Arnd Kohrs <kohrs@acm.org> | |
2550 | (define-setf-method oref (obj slot) | |
67868d26 CY |
2551 | (with-no-warnings |
2552 | (require 'cl) | |
2553 | (let ((obj-temp (gensym)) | |
2554 | (slot-temp (gensym)) | |
2555 | (store-temp (gensym))) | |
2556 | (list (list obj-temp slot-temp) | |
2557 | (list obj `(quote ,slot)) | |
2558 | (list store-temp) | |
2559 | (list 'set-slot-value obj-temp slot-temp | |
2560 | store-temp) | |
2561 | (list 'slot-value obj-temp slot-temp))))) | |
6dd12ef2 CY |
2562 | |
2563 | \f | |
2564 | ;;; | |
2565 | ;; We want all objects created by EIEIO to have some default set of | |
91af3942 | 2566 | ;; behaviors so we can create object utilities, and allow various |
6dd12ef2 CY |
2567 | ;; types of error checking. To do this, create the default EIEIO |
2568 | ;; class, and when no parent class is specified, use this as the | |
2569 | ;; default. (But don't store it in the other classes as the default, | |
2570 | ;; allowing for transparent support.) | |
2571 | ;; | |
2572 | ||
2573 | (defclass eieio-default-superclass nil | |
2574 | nil | |
2575 | "Default parent class for classes with no specified parent class. | |
a8f316ca JB |
2576 | Its slots are automatically adopted by classes with no specified parents. |
2577 | This class is not stored in the `parent' slot of a class vector." | |
6dd12ef2 CY |
2578 | :abstract t) |
2579 | ||
2580 | (defalias 'standard-class 'eieio-default-superclass) | |
2581 | ||
2582 | (defgeneric constructor (class newname &rest slots) | |
a8f316ca | 2583 | "Default constructor for CLASS `eieio-default-superclass'.") |
6dd12ef2 CY |
2584 | |
2585 | (defmethod constructor :static | |
2586 | ((class eieio-default-superclass) newname &rest slots) | |
a8f316ca | 2587 | "Default constructor for CLASS `eieio-default-superclass'. |
6dd12ef2 CY |
2588 | NEWNAME is the name to be given to the constructed object. |
2589 | SLOTS are the initialization slots used by `shared-initialize'. | |
2590 | This static method is called when an object is constructed. | |
2591 | It allocates the vector used to represent an EIEIO object, and then | |
2592 | calls `shared-initialize' on that object." | |
2593 | (let* ((new-object (copy-sequence (aref (class-v class) | |
2594 | class-default-object-cache)))) | |
2595 | ;; Update the name for the newly created object. | |
2596 | (aset new-object object-name newname) | |
2597 | ;; Call the initialize method on the new object with the slots | |
2598 | ;; that were passed down to us. | |
2599 | (initialize-instance new-object slots) | |
2600 | ;; Return the created object. | |
2601 | new-object)) | |
2602 | ||
2603 | (defgeneric shared-initialize (obj slots) | |
2604 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. | |
2605 | Called from the constructor routine.") | |
2606 | ||
2607 | (defmethod shared-initialize ((obj eieio-default-superclass) slots) | |
2608 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. | |
2609 | Called from the constructor routine." | |
2610 | (let ((scoped-class (aref obj object-class))) | |
2611 | (while slots | |
2612 | (let ((rn (eieio-initarg-to-attribute (object-class-fast obj) | |
2613 | (car slots)))) | |
2614 | (if (not rn) | |
2615 | (slot-missing obj (car slots) 'oset (car (cdr slots))) | |
2616 | (eieio-oset obj rn (car (cdr slots))))) | |
2617 | (setq slots (cdr (cdr slots)))))) | |
2618 | ||
2619 | (defgeneric initialize-instance (this &optional slots) | |
a8f316ca | 2620 | "Construct the new object THIS based on SLOTS.") |
6dd12ef2 CY |
2621 | |
2622 | (defmethod initialize-instance ((this eieio-default-superclass) | |
2623 | &optional slots) | |
a8f316ca | 2624 | "Construct the new object THIS based on SLOTS. |
6dd12ef2 | 2625 | SLOTS is a tagged list where odd numbered elements are tags, and |
a8f316ca JB |
2626 | even numbered elements are the values to store in the tagged slot. |
2627 | If you overload the `initialize-instance', there you will need to | |
2628 | call `shared-initialize' yourself, or you can call `call-next-method' | |
2629 | to have this constructor called automatically. If these steps are | |
2630 | not taken, then new objects of your class will not have their values | |
6dd12ef2 CY |
2631 | dynamically set from SLOTS." |
2632 | ;; First, see if any of our defaults are `lambda', and | |
2633 | ;; re-evaluate them and apply the value to our slots. | |
2634 | (let* ((scoped-class (class-v (aref this object-class))) | |
2635 | (slot (aref scoped-class class-public-a)) | |
2636 | (defaults (aref scoped-class class-public-d))) | |
2637 | (while slot | |
a2930e43 EL |
2638 | ;; For each slot, see if we need to evaluate it. |
2639 | ;; | |
2640 | ;; Paul Landes said in an email: | |
2641 | ;; > CL evaluates it if it can, and otherwise, leaves it as | |
2642 | ;; > the quoted thing as you already have. This is by the | |
2643 | ;; > Sonya E. Keene book and other things I've look at on the | |
2644 | ;; > web. | |
2645 | (let ((dflt (eieio-default-eval-maybe (car defaults)))) | |
2646 | (when (not (eq dflt (car defaults))) | |
2647 | (eieio-oset this (car slot) dflt) )) | |
2648 | ;; Next. | |
6dd12ef2 CY |
2649 | (setq slot (cdr slot) |
2650 | defaults (cdr defaults)))) | |
2651 | ;; Shared initialize will parse our slots for us. | |
2652 | (shared-initialize this slots)) | |
2653 | ||
2654 | (defgeneric slot-missing (object slot-name operation &optional new-value) | |
2655 | "Method invoked when an attempt to access a slot in OBJECT fails.") | |
2656 | ||
2657 | (defmethod slot-missing ((object eieio-default-superclass) slot-name | |
2658 | operation &optional new-value) | |
2659 | "Method invoked when an attempt to access a slot in OBJECT fails. | |
2660 | SLOT-NAME is the name of the failed slot, OPERATION is the type of access | |
2661 | that was requested, and optional NEW-VALUE is the value that was desired | |
2662 | to be set. | |
2663 | ||
2664 | This method is called from `oref', `oset', and other functions which | |
2665 | directly reference slots in EIEIO objects." | |
2666 | (signal 'invalid-slot-name (list (object-name object) | |
2667 | slot-name))) | |
2668 | ||
2669 | (defgeneric slot-unbound (object class slot-name fn) | |
2670 | "Slot unbound is invoked during an attempt to reference an unbound slot.") | |
2671 | ||
2672 | (defmethod slot-unbound ((object eieio-default-superclass) | |
2673 | class slot-name fn) | |
2674 | "Slot unbound is invoked during an attempt to reference an unbound slot. | |
2675 | OBJECT is the instance of the object being reference. CLASS is the | |
2676 | class of OBJECT, and SLOT-NAME is the offending slot. This function | |
2677 | throws the signal `unbound-slot'. You can overload this function and | |
2678 | return the value to use in place of the unbound value. | |
2679 | Argument FN is the function signaling this error. | |
2680 | Use `slot-boundp' to determine if a slot is bound or not. | |
2681 | ||
2682 | In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but | |
2683 | EIEIO can only dispatch on the first argument, so the first two are swapped." | |
2684 | (signal 'unbound-slot (list (class-name class) (object-name object) | |
2685 | slot-name fn))) | |
2686 | ||
2687 | (defgeneric no-applicable-method (object method &rest args) | |
2688 | "Called if there are no implementations for OBJECT in METHOD.") | |
2689 | ||
2690 | (defmethod no-applicable-method ((object eieio-default-superclass) | |
2691 | method &rest args) | |
2692 | "Called if there are no implementations for OBJECT in METHOD. | |
2693 | OBJECT is the object which has no method implementation. | |
2694 | ARGS are the arguments that were passed to METHOD. | |
2695 | ||
2696 | Implement this for a class to block this signal. The return | |
2697 | value becomes the return value of the original method call." | |
2698 | (signal 'no-method-definition (list method (object-name object))) | |
2699 | ) | |
2700 | ||
2701 | (defgeneric no-next-method (object &rest args) | |
2702 | "Called from `call-next-method' when no additional methods are available.") | |
2703 | ||
2704 | (defmethod no-next-method ((object eieio-default-superclass) | |
2705 | &rest args) | |
2706 | "Called from `call-next-method' when no additional methods are available. | |
2707 | OBJECT is othe object being called on `call-next-method'. | |
a8f316ca | 2708 | ARGS are the arguments it is called by. |
6dd12ef2 | 2709 | This method signals `no-next-method' by default. Override this |
a8f316ca | 2710 | method to not throw an error, and its return value becomes the |
6dd12ef2 CY |
2711 | return value of `call-next-method'." |
2712 | (signal 'no-next-method (list (object-name object) args)) | |
2713 | ) | |
2714 | ||
2715 | (defgeneric clone (obj &rest params) | |
2716 | "Make a copy of OBJ, and then supply PARAMS. | |
2717 | PARAMS is a parameter list of the same form used by `initialize-instance'. | |
2718 | ||
2719 | When overloading `clone', be sure to call `call-next-method' | |
2720 | first and modify the returned object.") | |
2721 | ||
2722 | (defmethod clone ((obj eieio-default-superclass) &rest params) | |
2723 | "Make a copy of OBJ, and then apply PARAMS." | |
2724 | (let ((nobj (copy-sequence obj)) | |
2725 | (nm (aref obj object-name)) | |
2726 | (passname (and params (stringp (car params)))) | |
2727 | (num 1)) | |
2728 | (if params (shared-initialize nobj (if passname (cdr params) params))) | |
2729 | (if (not passname) | |
2730 | (save-match-data | |
2731 | (if (string-match "-\\([0-9]+\\)" nm) | |
2732 | (setq num (1+ (string-to-number (match-string 1 nm))) | |
2733 | nm (substring nm 0 (match-beginning 0)))) | |
2734 | (aset nobj object-name (concat nm "-" (int-to-string num)))) | |
2735 | (aset nobj object-name (car params))) | |
2736 | nobj)) | |
2737 | ||
2738 | (defgeneric destructor (this &rest params) | |
2739 | "Destructor for cleaning up any dynamic links to our object.") | |
2740 | ||
2741 | (defmethod destructor ((this eieio-default-superclass) &rest params) | |
2742 | "Destructor for cleaning up any dynamic links to our object. | |
2743 | Argument THIS is the object being destroyed. PARAMS are additional | |
2744 | ignored parameters." | |
2745 | ;; No cleanup... yet. | |
2746 | ) | |
2747 | ||
2748 | (defgeneric object-print (this &rest strings) | |
2749 | "Pretty printer for object THIS. Call function `object-name' with STRINGS. | |
2750 | ||
2751 | It is sometimes useful to put a summary of the object into the | |
a8f316ca | 2752 | default #<notation> string when using EIEIO browsing tools. |
6dd12ef2 CY |
2753 | Implement this method to customize the summary.") |
2754 | ||
2755 | (defmethod object-print ((this eieio-default-superclass) &rest strings) | |
2756 | "Pretty printer for object THIS. Call function `object-name' with STRINGS. | |
2757 | The default method for printing object THIS is to use the | |
2758 | function `object-name'. | |
2759 | ||
2760 | It is sometimes useful to put a summary of the object into the | |
a8f316ca | 2761 | default #<notation> string when using EIEIO browsing tools. |
6dd12ef2 CY |
2762 | |
2763 | Implement this function and specify STRINGS in a call to | |
2764 | `call-next-method' to provide additional summary information. | |
2765 | When passing in extra strings from child classes, always remember | |
2766 | to prepend a space." | |
2767 | (object-name this (apply 'concat strings))) | |
2768 | ||
2769 | (defvar eieio-print-depth 0 | |
2770 | "When printing, keep track of the current indentation depth.") | |
2771 | ||
2772 | (defgeneric object-write (this &optional comment) | |
2773 | "Write out object THIS to the current stream. | |
a8f316ca | 2774 | Optional COMMENT will add comments to the beginning of the output.") |
6dd12ef2 CY |
2775 | |
2776 | (defmethod object-write ((this eieio-default-superclass) &optional comment) | |
2777 | "Write object THIS out to the current stream. | |
2778 | This writes out the vector version of this object. Complex and recursive | |
2779 | object are discouraged from being written. | |
2780 | If optional COMMENT is non-nil, include comments when outputting | |
2781 | this object." | |
2782 | (when comment | |
2783 | (princ ";; Object ") | |
2784 | (princ (object-name-string this)) | |
2785 | (princ "\n") | |
2786 | (princ comment) | |
2787 | (princ "\n")) | |
2788 | (let* ((cl (object-class this)) | |
2789 | (cv (class-v cl))) | |
2790 | ;; Now output readable lisp to recreate this object | |
2791 | ;; It should look like this: | |
2792 | ;; (<constructor> <name> <slot> <slot> ... ) | |
2793 | ;; Each slot's slot is writen using its :writer. | |
2794 | (princ (make-string (* eieio-print-depth 2) ? )) | |
2795 | (princ "(") | |
2796 | (princ (symbol-name (class-constructor (object-class this)))) | |
2797 | (princ " \"") | |
2798 | (princ (object-name-string this)) | |
2799 | (princ "\"\n") | |
2800 | ;; Loop over all the public slots | |
2801 | (let ((publa (aref cv class-public-a)) | |
2802 | (publd (aref cv class-public-d)) | |
2803 | (publp (aref cv class-public-printer)) | |
2804 | (eieio-print-depth (1+ eieio-print-depth))) | |
2805 | (while publa | |
2806 | (when (slot-boundp this (car publa)) | |
2807 | (let ((i (class-slot-initarg cl (car publa))) | |
2808 | (v (eieio-oref this (car publa))) | |
2809 | ) | |
2810 | (unless (or (not i) (equal v (car publd))) | |
2811 | (princ (make-string (* eieio-print-depth 2) ? )) | |
2812 | (princ (symbol-name i)) | |
2813 | (princ " ") | |
2814 | (if (car publp) | |
2815 | ;; Use our public printer | |
2816 | (funcall (car publp) v) | |
2817 | ;; Use our generic override prin1 function. | |
2818 | (eieio-override-prin1 v)) | |
2819 | (princ "\n")))) | |
2820 | (setq publa (cdr publa) publd (cdr publd) | |
2821 | publp (cdr publp))) | |
2822 | (princ (make-string (* eieio-print-depth 2) ? ))) | |
2823 | (princ ")\n"))) | |
2824 | ||
2825 | (defun eieio-override-prin1 (thing) | |
a8f316ca | 2826 | "Perform a `prin1' on THING taking advantage of object knowledge." |
6dd12ef2 CY |
2827 | (cond ((eieio-object-p thing) |
2828 | (object-write thing)) | |
2829 | ((listp thing) | |
2830 | (eieio-list-prin1 thing)) | |
2831 | ((class-p thing) | |
2832 | (princ (class-name thing))) | |
2833 | ((symbolp thing) | |
2834 | (princ (concat "'" (symbol-name thing)))) | |
2835 | (t (prin1 thing)))) | |
2836 | ||
2837 | (defun eieio-list-prin1 (list) | |
2838 | "Display LIST where list may contain objects." | |
2839 | (if (not (eieio-object-p (car list))) | |
2840 | (progn | |
2841 | (princ "'") | |
2842 | (prin1 list)) | |
2843 | (princ "(list ") | |
2844 | (if (eieio-object-p (car list)) (princ "\n ")) | |
2845 | (while list | |
2846 | (if (eieio-object-p (car list)) | |
2847 | (object-write (car list)) | |
2848 | (princ "'") | |
2849 | (prin1 (car list))) | |
2850 | (princ " ") | |
2851 | (setq list (cdr list))) | |
2852 | (princ (make-string (* eieio-print-depth 2) ? )) | |
2853 | (princ ")"))) | |
2854 | ||
2855 | \f | |
2856 | ;;; Unimplemented functions from CLOS | |
2857 | ;; | |
2858 | (defun change-class (obj class) | |
2859 | "Change the class of OBJ to type CLASS. | |
2860 | This may create or delete slots, but does not affect the return value | |
2861 | of `eq'." | |
a8f316ca | 2862 | (error "EIEIO: `change-class' is unimplemented")) |
6dd12ef2 CY |
2863 | |
2864 | ) | |
2865 | ||
2866 | \f | |
93b6b5e1 SM |
2867 | ;;; Obsolete backward compatibility functions. |
2868 | ;; Needed to run byte-code compiled with the EIEIO of Emacs-23. | |
2869 | ||
2870 | (defun eieio-defmethod (method args) | |
2871 | "Obsolete work part of an old version of the `defmethod' macro." | |
2872 | (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) | |
2873 | ;; find optional keys | |
2874 | (setq key | |
2875 | (cond ((or (eq ':BEFORE (car args)) | |
2876 | (eq ':before (car args))) | |
2877 | (setq args (cdr args)) | |
2878 | method-before) | |
2879 | ((or (eq ':AFTER (car args)) | |
2880 | (eq ':after (car args))) | |
2881 | (setq args (cdr args)) | |
2882 | method-after) | |
2883 | ((or (eq ':PRIMARY (car args)) | |
2884 | (eq ':primary (car args))) | |
2885 | (setq args (cdr args)) | |
2886 | method-primary) | |
2887 | ((or (eq ':STATIC (car args)) | |
2888 | (eq ':static (car args))) | |
2889 | (setq args (cdr args)) | |
2890 | method-static) | |
2891 | ;; Primary key | |
2892 | (t method-primary))) | |
2893 | ;; get body, and fix contents of args to be the arguments of the fn. | |
2894 | (setq body (cdr args) | |
2895 | args (car args)) | |
2896 | (setq loopa args) | |
2897 | ;; Create a fixed version of the arguments | |
2898 | (while loopa | |
2899 | (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) | |
2900 | argfix)) | |
2901 | (setq loopa (cdr loopa))) | |
2902 | ;; make sure there is a generic | |
2903 | (eieio-defgeneric | |
2904 | method | |
2905 | (if (stringp (car body)) | |
2906 | (car body) (format "Generically created method `%s'." method))) | |
2907 | ;; create symbol for property to bind to. If the first arg is of | |
2908 | ;; the form (varname vartype) and `vartype' is a class, then | |
2909 | ;; that class will be the type symbol. If not, then it will fall | |
2910 | ;; under the type `primary' which is a non-specific calling of the | |
2911 | ;; function. | |
2912 | (setq firstarg (car args)) | |
2913 | (if (listp firstarg) | |
2914 | (progn | |
2915 | (setq argclass (nth 1 firstarg)) | |
2916 | (if (not (class-p argclass)) | |
2917 | (error "Unknown class type %s in method parameters" | |
2918 | (nth 1 firstarg)))) | |
2919 | (if (= key -1) | |
2920 | (signal 'wrong-type-argument (list :static 'non-class-arg))) | |
2921 | ;; generics are higher | |
2922 | (setq key (eieio-specialized-key-to-generic-key key))) | |
2923 | ;; Put this lambda into the symbol so we can find it | |
2924 | (if (byte-code-function-p (car-safe body)) | |
2925 | (eieiomt-add method (car-safe body) key argclass) | |
2926 | (eieiomt-add method (append (list 'lambda (reverse argfix)) body) | |
2927 | key argclass)) | |
2928 | ) | |
2929 | ||
2930 | (when eieio-optimize-primary-methods-flag | |
2931 | ;; Optimizing step: | |
2932 | ;; | |
2933 | ;; If this method, after this setup, only has primary methods, then | |
2934 | ;; we can setup the generic that way. | |
2935 | (if (generic-primary-only-p method) | |
2936 | ;; If there is only one primary method, then we can go one more | |
2937 | ;; optimization step. | |
2938 | (if (generic-primary-only-one-p method) | |
2939 | (eieio-defgeneric-reset-generic-form-primary-only-one method) | |
2940 | (eieio-defgeneric-reset-generic-form-primary-only method)) | |
2941 | (eieio-defgeneric-reset-generic-form method))) | |
2942 | ||
2943 | method) | |
2944 | (make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") | |
2945 | ||
2946 | (defun eieio-defgeneric (method doc-string) | |
2947 | "Obsolete work part of an old version of the `defgeneric' macro." | |
2948 | (if (and (fboundp method) (not (generic-p method)) | |
2949 | (or (byte-code-function-p (symbol-function method)) | |
2950 | (not (eq 'autoload (car (symbol-function method))))) | |
2951 | ) | |
2952 | (error "You cannot create a generic/method over an existing symbol: %s" | |
2953 | method)) | |
2954 | ;; Don't do this over and over. | |
2955 | (unless (fboundp 'method) | |
2956 | ;; This defun tells emacs where the first definition of this | |
2957 | ;; method is defined. | |
2958 | `(defun ,method nil) | |
2959 | ;; Make sure the method tables are installed. | |
2960 | (eieiomt-install method) | |
2961 | ;; Apply the actual body of this function. | |
2962 | (fset method (eieio-defgeneric-form method doc-string)) | |
2963 | ;; Return the method | |
2964 | 'method)) | |
2965 | (make-obsolete 'eieio-defgeneric nil "24.1") | |
2966 | ||
6dd12ef2 CY |
2967 | ;;; Interfacing with edebug |
2968 | ;; | |
2969 | (defun eieio-edebug-prin1-to-string (object &optional noescape) | |
a8f316ca JB |
2970 | "Display EIEIO OBJECT in fancy format. |
2971 | Overrides the edebug default. | |
6dd12ef2 CY |
2972 | Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." |
2973 | (cond ((class-p object) (class-name object)) | |
2974 | ((eieio-object-p object) (object-print object)) | |
2975 | ((and (listp object) (or (class-p (car object)) | |
2976 | (eieio-object-p (car object)))) | |
2977 | (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) | |
2978 | (t (prin1-to-string object noescape)))) | |
2979 | ||
2980 | (add-hook 'edebug-setup-hook | |
2981 | (lambda () | |
2982 | (def-edebug-spec defmethod | |
2983 | (&define ; this means we are defining something | |
2984 | [&or name ("setf" :name setf name)] | |
2985 | ;; ^^ This is the methods symbol | |
2986 | [ &optional symbolp ] ; this is key :before etc | |
2987 | list ; arguments | |
2988 | [ &optional stringp ] ; documentation string | |
2989 | def-body ; part to be debugged | |
2990 | )) | |
2991 | ;; The rest of the macros | |
2992 | (def-edebug-spec oref (form quote)) | |
2993 | (def-edebug-spec oref-default (form quote)) | |
2994 | (def-edebug-spec oset (form quote form)) | |
2995 | (def-edebug-spec oset-default (form quote form)) | |
2996 | (def-edebug-spec class-v form) | |
2997 | (def-edebug-spec class-p form) | |
2998 | (def-edebug-spec eieio-object-p form) | |
2999 | (def-edebug-spec class-constructor form) | |
3000 | (def-edebug-spec generic-p form) | |
3001 | (def-edebug-spec with-slots (list list def-body)) | |
3002 | ;; I suspect this isn't the best way to do this, but when | |
3003 | ;; cust-print was used on my system all my objects | |
3004 | ;; appeared as "#1 =" which was not useful. This allows | |
3005 | ;; edebug to print my objects in the nice way they were | |
3006 | ;; meant to with `object-print' and `class-name' | |
3007 | ;; (defalias 'edebug-prin1-to-string 'eieio-edebug-prin1-to-string) | |
3008 | ) | |
3009 | ) | |
3010 | ||
6dd12ef2 CY |
3011 | ;;; Interfacing with imenu in emacs lisp mode |
3012 | ;; (Only if the expression is defined) | |
3013 | ;; | |
3014 | (if (eval-when-compile (boundp 'list-imenu-generic-expression)) | |
3015 | (progn | |
3016 | ||
3017 | (defun eieio-update-lisp-imenu-expression () | |
3018 | "Examine `lisp-imenu-generic-expression' and modify it to find `defmethod'." | |
3019 | (let ((exp lisp-imenu-generic-expression)) | |
3020 | (while exp | |
3021 | ;; it's of the form '( ( title expr indx ) ... ) | |
3022 | (let* ((subcar (cdr (car exp))) | |
3023 | (substr (car subcar))) | |
3024 | (if (and (not (string-match "|method\\\\" substr)) | |
3025 | (string-match "|advice\\\\" substr)) | |
3026 | (setcar subcar | |
3027 | (replace-match "|advice\\|method\\" t t substr 0)))) | |
3028 | (setq exp (cdr exp))))) | |
3029 | ||
3030 | (eieio-update-lisp-imenu-expression) | |
3031 | ||
3032 | )) | |
3033 | ||
3034 | ;;; Autoloading some external symbols, and hooking into the help system | |
3035 | ;; | |
3036 | ||
002b46b7 GM |
3037 | \f |
3038 | ;;; Start of automatically extracted autoloads. | |
3039 | \f | |
3040 | ;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el" | |
3041 | ;;;;;; "cf1bd64c76a6e6406545e8c5a5530d43") | |
3042 | ;;; Generated autoloads from eieio-custom.el | |
3043 | ||
3044 | (autoload 'customize-object "eieio-custom" "\ | |
3045 | Customize OBJ in a custom buffer. | |
3046 | Optional argument GROUP is the sub-group of slots to display. | |
3047 | ||
3048 | \(fn OBJ &optional GROUP)" nil nil) | |
3049 | ||
3050 | ;;;*** | |
3051 | \f | |
3052 | ;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic | |
3053 | ;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse) | |
ce7ddba0 | 3054 | ;;;;;; "eieio-opt" "eieio-opt.el" "4fb6625c3a007438aab4e8e77b6c73c2") |
002b46b7 GM |
3055 | ;;; Generated autoloads from eieio-opt.el |
3056 | ||
3057 | (autoload 'eieio-browse "eieio-opt" "\ | |
3058 | Create an object browser window to show all objects. | |
3059 | If optional ROOT-CLASS, then start with that, otherwise start with | |
3060 | variable `eieio-default-superclass'. | |
3061 | ||
3062 | \(fn &optional ROOT-CLASS)" t nil) | |
3063 | ||
3064 | (defalias 'describe-class 'eieio-describe-class) | |
3065 | ||
3066 | (autoload 'eieio-describe-class "eieio-opt" "\ | |
3067 | Describe a CLASS defined by a string or symbol. | |
3068 | If CLASS is actually an object, then also display current values of that object. | |
3069 | Optional HEADERFCN should be called to insert a few bits of info first. | |
3070 | ||
3071 | \(fn CLASS &optional HEADERFCN)" t nil) | |
3072 | ||
3073 | (autoload 'eieio-describe-constructor "eieio-opt" "\ | |
3074 | Describe the constructor function FCN. | |
3075 | Uses `eieio-describe-class' to describe the class being constructed. | |
3076 | ||
3077 | \(fn FCN)" t nil) | |
3078 | ||
3079 | (defalias 'describe-generic 'eieio-describe-generic) | |
3080 | ||
3081 | (autoload 'eieio-describe-generic "eieio-opt" "\ | |
3082 | Describe the generic function GENERIC. | |
3083 | Also extracts information about all methods specific to this generic. | |
3084 | ||
3085 | \(fn GENERIC)" t nil) | |
3086 | ||
3087 | (autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "\ | |
3088 | For buffers thrown into help mode, augment for EIEIO. | |
3089 | Arguments UNUSED are not used. | |
3090 | ||
3091 | \(fn &rest UNUSED)" nil nil) | |
3092 | ||
3093 | ;;;*** | |
3094 | \f | |
3095 | ;;; End of automatically extracted autoloads. | |
6dd12ef2 CY |
3096 | |
3097 | (provide 'eieio) | |
3098 | ||
6dd12ef2 | 3099 | ;;; eieio ends here |