Commit | Line | Data |
---|---|---|
890f7890 DE |
1 | ;;; eieio-core.el --- Core implementation for eieio |
2 | ||
3 | ;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
6 | ;; Version: 1.4 | |
7 | ;; Keywords: OO, lisp | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
13 | ;; the Free Software Foundation, either version 3 of the License, or | |
14 | ;; (at your option) any later version. | |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | ;;; Commentary: | |
25 | ;; | |
26 | ;; The "core" part of EIEIO is the implementation for the object | |
27 | ;; system (such as eieio-defclass, or eieio-defmethod) but not the | |
28 | ;; base classes for the object system, which are defined in EIEIO. | |
29 | ;; | |
30 | ;; See the commentary for eieio.el for more about EIEIO itself. | |
31 | ||
32 | ;;; Code: | |
33 | ||
34 | (eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! | |
35 | ||
36 | ;; Compatibility | |
37 | (if (fboundp 'compiled-function-arglist) | |
38 | ||
39 | ;; XEmacs can only access a compiled functions arglist like this: | |
40 | (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) | |
41 | ||
42 | ;; Emacs doesn't have this function, but since FUNC is a vector, we can just | |
43 | ;; grab the appropriate element. | |
44 | (defun eieio-compiled-function-arglist (func) | |
45 | "Return the argument list for the compiled function FUNC." | |
46 | (aref func 0)) | |
47 | ||
48 | ) | |
49 | ||
50 | (put 'eieio--defalias 'byte-hunk-handler | |
51 | #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) | |
52 | (defun eieio--defalias (name body) | |
53 | "Like `defalias', but with less side-effects. | |
54 | More specifically, it has no side-effects at all when the new function | |
55 | definition is the same (`eq') as the old one." | |
56 | (unless (and (fboundp name) | |
57 | (eq (symbol-function name) body)) | |
58 | (defalias name body))) | |
59 | ||
60 | ;;; | |
61 | ;; A few functions that are better in the official EIEIO src, but | |
62 | ;; used from the core. | |
63 | (declare-function slot-unbound "eieio") | |
64 | (declare-function slot-missing "eieio") | |
65 | (declare-function child-of-class-p "eieio") | |
66 | ||
67 | \f | |
68 | ;;; | |
69 | ;; Variable declarations. | |
70 | ;; | |
71 | (defvar eieio-hook nil | |
72 | "This hook is executed, then cleared each time `defclass' is called.") | |
73 | ||
74 | (defvar eieio-error-unsupported-class-tags nil | |
75 | "Non-nil to throw an error if an encountered tag is unsupported. | |
76 | This may prevent classes from CLOS applications from being used with EIEIO | |
77 | since EIEIO does not support all CLOS tags.") | |
78 | ||
79 | (defvar eieio-skip-typecheck nil | |
80 | "If non-nil, skip all slot typechecking. | |
81 | Set this to t permanently if a program is functioning well to get a | |
82 | small speed increase. This variable is also used internally to handle | |
83 | default setting for optimization purposes.") | |
84 | ||
85 | (defvar eieio-optimize-primary-methods-flag t | |
86 | "Non-nil means to optimize the method dispatch on primary methods.") | |
87 | ||
88 | (defvar eieio-initializing-object nil | |
89 | "Set to non-nil while initializing an object.") | |
90 | ||
91 | (defconst eieio-unbound | |
92 | (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) | |
93 | eieio-unbound | |
94 | (make-symbol "unbound")) | |
95 | "Uninterned symbol representing an unbound slot in an object.") | |
96 | ||
97 | ;; This is a bootstrap for eieio-default-superclass so it has a value | |
98 | ;; while it is being built itself. | |
99 | (defvar eieio-default-superclass nil) | |
100 | ||
101 | ;;; | |
102 | ;; Class currently in scope. | |
103 | ;; | |
104 | ;; When invoking methods, the running method needs to know which class | |
105 | ;; is currently in scope. Generally this is the class of the method | |
106 | ;; being called, but 'call-next-method' needs to query this state, | |
107 | ;; and change it to be then next super class up. | |
108 | ;; | |
109 | ;; Thus, the scoped class is a stack that needs to be managed. | |
110 | ||
111 | (defvar eieio--scoped-class-stack nil | |
112 | "A stack of the classes currently in scope during method invocation.") | |
113 | ||
114 | (defun eieio--scoped-class () | |
115 | "Return the class currently in scope, or nil." | |
116 | (car-safe eieio--scoped-class-stack)) | |
117 | ||
118 | (defmacro eieio--with-scoped-class (class &rest forms) | |
119 | "Set CLASS as the currently scoped class while executing FORMS." | |
120 | `(unwind-protect | |
121 | (progn | |
122 | (push ,class eieio--scoped-class-stack) | |
123 | ,@forms) | |
124 | (pop eieio--scoped-class-stack))) | |
125 | (put 'eieio--with-scoped-class 'lisp-indent-function 1) | |
126 | ||
127 | ;;; | |
128 | ;; Field Accessors | |
129 | ;; | |
130 | (defmacro eieio--define-field-accessors (prefix fields) | |
131 | (declare (indent 1)) | |
132 | (let ((index 0) | |
133 | (defs '())) | |
134 | (dolist (field fields) | |
135 | (let ((doc (if (listp field) | |
136 | (prog1 (cadr field) (setq field (car field)))))) | |
137 | (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) | |
138 | ,@(if doc (list (format (if (string-match "\n" doc) | |
139 | "Return %s" "Return %s of a %s.") | |
140 | doc prefix))) | |
141 | (list 'aref x ,index)) | |
142 | defs) | |
143 | (setq index (1+ index)))) | |
144 | `(eval-and-compile | |
145 | ,@(nreverse defs) | |
146 | (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) | |
147 | ||
148 | (eieio--define-field-accessors class | |
149 | (-unused-0 ;;FIXME: not sure, but at least there was no accessor! | |
150 | (symbol "symbol (self-referencing)") | |
151 | parent children | |
152 | (symbol-obarray "obarray permitting fast access to variable position indexes") | |
153 | ;; @todo | |
154 | ;; the word "public" here is leftovers from the very first version. | |
155 | ;; Get rid of it! | |
156 | (public-a "class attribute index") | |
157 | (public-d "class attribute defaults index") | |
158 | (public-doc "class documentation strings for attributes") | |
159 | (public-type "class type for a slot") | |
160 | (public-custom "class custom type for a slot") | |
161 | (public-custom-label "class custom group for a slot") | |
162 | (public-custom-group "class custom group for a slot") | |
163 | (public-printer "printer for a slot") | |
164 | (protection "protection for a slot") | |
165 | (initarg-tuples "initarg tuples list") | |
166 | (class-allocation-a "class allocated attributes") | |
167 | (class-allocation-doc "class allocated documentation") | |
168 | (class-allocation-type "class allocated value type") | |
169 | (class-allocation-custom "class allocated custom descriptor") | |
170 | (class-allocation-custom-label "class allocated custom descriptor") | |
171 | (class-allocation-custom-group "class allocated custom group") | |
172 | (class-allocation-printer "class allocated printer for a slot") | |
173 | (class-allocation-protection "class allocated protection list") | |
174 | (class-allocation-values "class allocated value vector") | |
175 | (default-object-cache "what a newly created object would look like. | |
176 | This will speed up instantiation time as only a `copy-sequence' will | |
177 | be needed, instead of looping over all the values and setting them | |
178 | from the default.") | |
179 | (options "storage location of tagged class options. | |
180 | Stored outright without modifications or stripping."))) | |
181 | ||
182 | (eieio--define-field-accessors object | |
183 | (-unused-0 ;;FIXME: not sure, but at least there was no accessor! | |
184 | (class "class struct defining OBJ") | |
185 | name)) | |
186 | ||
187 | ;; FIXME: The constants below should have an `eieio-' prefix added!! | |
188 | ||
189 | (defconst method-static 0 "Index into :static tag on a method.") | |
190 | (defconst method-before 1 "Index into :before tag on a method.") | |
191 | (defconst method-primary 2 "Index into :primary tag on a method.") | |
192 | (defconst method-after 3 "Index into :after tag on a method.") | |
193 | (defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") | |
194 | (defconst method-generic-before 4 "Index into generic :before tag on a method.") | |
195 | (defconst method-generic-primary 5 "Index into generic :primary tag on a method.") | |
196 | (defconst method-generic-after 6 "Index into generic :after tag on a method.") | |
197 | (defconst method-num-slots 7 "Number of indexes into a method's vector.") | |
198 | ||
199 | (defsubst eieio-specialized-key-to-generic-key (key) | |
200 | "Convert a specialized KEY into a generic method key." | |
201 | (cond ((eq key method-static) 0) ;; don't convert | |
202 | ((< key method-num-lists) (+ key 3)) ;; The conversion | |
203 | (t key) ;; already generic.. maybe. | |
204 | )) | |
205 | ||
206 | \f | |
207 | ;;; Important macros used internally in eieio. | |
208 | ;; | |
209 | (defmacro eieio--check-type (type obj) | |
210 | (unless (symbolp obj) | |
211 | (error "eieio--check-type wants OBJ to be a variable")) | |
212 | `(if (not ,(cond | |
213 | ((eq 'or (car-safe type)) | |
214 | `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type)))) | |
215 | (t `(,type ,obj)))) | |
216 | (signal 'wrong-type-argument (list ',type ,obj)))) | |
217 | ||
218 | (defmacro class-v (class) | |
219 | "Internal: Return the class vector from the CLASS symbol." | |
220 | ;; No check: If eieio gets this far, it has probably been checked already. | |
221 | `(get ,class 'eieio-class-definition)) | |
222 | ||
223 | (defmacro class-p (class) | |
224 | "Return t if CLASS is a valid class vector. | |
225 | CLASS is a symbol." | |
226 | ;; this new method is faster since it doesn't waste time checking lots of | |
227 | ;; things. | |
228 | `(condition-case nil | |
229 | (eq (aref (class-v ,class) 0) 'defclass) | |
230 | (error nil))) | |
231 | ||
232 | (defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." | |
233 | (eieio--check-type class-p class) | |
234 | ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, | |
235 | ;; and I wanted a string. Arg! | |
236 | (format "#<class %s>" (symbol-name class))) | |
237 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") | |
238 | ||
239 | (defmacro eieio-class-parents-fast (class) | |
240 | "Return parent classes to CLASS with no check." | |
241 | `(eieio--class-parent (class-v ,class))) | |
242 | ||
243 | (defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." | |
244 | `(eieio--class-children (class-v ,class))) | |
245 | ||
246 | (defmacro same-class-fast-p (obj class) | |
247 | "Return t if OBJ is of class-type CLASS with no error checking." | |
248 | `(eq (eieio--object-class ,obj) ,class)) | |
249 | ||
250 | (defmacro class-constructor (class) | |
251 | "Return the symbol representing the constructor of CLASS." | |
252 | `(eieio--class-symbol (class-v ,class))) | |
253 | ||
254 | (defmacro generic-p (method) | |
255 | "Return t if symbol METHOD is a generic function. | |
256 | Only methods have the symbol `eieio-method-obarray' as a property | |
257 | \(which contains a list of all bindings to that method type.)" | |
258 | `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) | |
259 | ||
260 | (defun generic-primary-only-p (method) | |
261 | "Return t if symbol METHOD is a generic function with only primary methods. | |
262 | Only methods have the symbol `eieio-method-obarray' as a property (which | |
263 | contains a list of all bindings to that method type.) | |
264 | Methods with only primary implementations are executed in an optimized way." | |
265 | (and (generic-p method) | |
266 | (let ((M (get method 'eieio-method-tree))) | |
267 | (and (< 0 (length (aref M method-primary))) | |
268 | (not (aref M method-static)) | |
269 | (not (aref M method-before)) | |
270 | (not (aref M method-after)) | |
271 | (not (aref M method-generic-before)) | |
272 | (not (aref M method-generic-primary)) | |
273 | (not (aref M method-generic-after)))) | |
274 | )) | |
275 | ||
276 | (defun generic-primary-only-one-p (method) | |
277 | "Return t if symbol METHOD is a generic function with only primary methods. | |
278 | Only methods have the symbol `eieio-method-obarray' as a property (which | |
279 | contains a list of all bindings to that method type.) | |
280 | Methods with only primary implementations are executed in an optimized way." | |
281 | (and (generic-p method) | |
282 | (let ((M (get method 'eieio-method-tree))) | |
283 | (and (= 1 (length (aref M method-primary))) | |
284 | (not (aref M method-static)) | |
285 | (not (aref M method-before)) | |
286 | (not (aref M method-after)) | |
287 | (not (aref M method-generic-before)) | |
288 | (not (aref M method-generic-primary)) | |
289 | (not (aref M method-generic-after)))) | |
290 | )) | |
291 | ||
292 | (defmacro class-option-assoc (list option) | |
293 | "Return from LIST the found OPTION, or nil if it doesn't exist." | |
294 | `(car-safe (cdr (memq ,option ,list)))) | |
295 | ||
296 | (defmacro class-option (class option) | |
297 | "Return the value stored for CLASS' OPTION. | |
298 | Return nil if that option doesn't exist." | |
299 | `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) | |
300 | ||
301 | (defmacro eieio-object-p (obj) | |
302 | "Return non-nil if OBJ is an EIEIO object." | |
303 | `(condition-case nil | |
304 | (let ((tobj ,obj)) | |
305 | (and (eq (aref tobj 0) 'object) | |
306 | (class-p (eieio--object-class tobj)))) | |
307 | (error nil))) | |
308 | (defalias 'object-p 'eieio-object-p) | |
309 | ||
310 | (defmacro class-abstract-p (class) | |
311 | "Return non-nil if CLASS is abstract. | |
312 | Abstract classes cannot be instantiated." | |
313 | `(class-option ,class :abstract)) | |
314 | ||
315 | (defmacro class-method-invocation-order (class) | |
316 | "Return the invocation order of CLASS. | |
317 | Abstract classes cannot be instantiated." | |
318 | `(or (class-option ,class :method-invocation-order) | |
319 | :breadth-first)) | |
320 | ||
321 | ||
322 | \f | |
323 | ;;; | |
324 | ;; Class Creation | |
325 | ||
326 | (defvar eieio-defclass-autoload-map (make-vector 7 nil) | |
327 | "Symbol map of superclasses we find in autoloads.") | |
328 | ||
329 | ;; We autoload this because it's used in `make-autoload'. | |
330 | ;;;###autoload | |
331 | (defun eieio-defclass-autoload (cname superclasses filename doc) | |
332 | "Create autoload symbols for the EIEIO class CNAME. | |
333 | SUPERCLASSES are the superclasses that CNAME inherits from. | |
334 | DOC is the docstring for CNAME. | |
335 | This function creates a mock-class for CNAME and adds it into | |
336 | SUPERCLASSES as children. | |
337 | It creates an autoload function for CNAME's constructor." | |
338 | ;; Assume we've already debugged inputs. | |
339 | ||
340 | (let* ((oldc (when (class-p cname) (class-v cname))) | |
341 | (newc (make-vector eieio--class-num-slots nil)) | |
342 | ) | |
343 | (if oldc | |
344 | nil ;; Do nothing if we already have this class. | |
345 | ||
346 | ;; Create the class in NEWC, but don't fill anything else in. | |
347 | (aset newc 0 'defclass) | |
348 | (setf (eieio--class-symbol newc) cname) | |
349 | ||
350 | (let ((clear-parent nil)) | |
351 | ;; No parents? | |
352 | (when (not superclasses) | |
353 | (setq superclasses '(eieio-default-superclass) | |
354 | clear-parent t) | |
355 | ) | |
356 | ||
357 | ;; Hook our new class into the existing structures so we can | |
358 | ;; autoload it later. | |
359 | (dolist (SC superclasses) | |
360 | ||
361 | ||
362 | ;; TODO - If we create an autoload that is in the map, that | |
363 | ;; map needs to be cleared! | |
364 | ||
365 | ||
366 | ;; Does our parent exist? | |
367 | (if (not (class-p SC)) | |
368 | ||
369 | ;; Create a symbol for this parent, and then store this | |
370 | ;; parent on that symbol. | |
371 | (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) | |
372 | (if (not (boundp sym)) | |
373 | (set sym (list cname)) | |
374 | (add-to-list sym cname)) | |
375 | ) | |
376 | ||
377 | ;; We have a parent, save the child in there. | |
378 | (when (not (member cname (eieio--class-children (class-v SC)))) | |
379 | (setf (eieio--class-children (class-v SC)) | |
380 | (cons cname (eieio--class-children (class-v SC)))))) | |
381 | ||
382 | ;; save parent in child | |
383 | (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc))) | |
384 | ) | |
385 | ||
386 | ;; turn this into a usable self-pointing symbol | |
387 | (set cname cname) | |
388 | ||
389 | ;; Store the new class vector definition into the symbol. We need to | |
390 | ;; do this first so that we can call defmethod for the accessor. | |
391 | ;; The vector will be updated by the following while loop and will not | |
392 | ;; need to be stored a second time. | |
393 | (put cname 'eieio-class-definition newc) | |
394 | ||
395 | ;; Clear the parent | |
396 | (if clear-parent (setf (eieio--class-parent newc) nil)) | |
397 | ||
398 | ;; Create an autoload on top of our constructor function. | |
399 | (autoload cname filename doc nil nil) | |
400 | (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) | |
401 | (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) | |
402 | (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) | |
403 | ||
404 | )))) | |
405 | ||
406 | (defsubst eieio-class-un-autoload (cname) | |
407 | "If class CNAME is in an autoload state, load its file." | |
408 | (when (eq (car-safe (symbol-function cname)) 'autoload) | |
409 | (load-library (car (cdr (symbol-function cname)))))) | |
410 | ||
411 | (defun eieio-defclass (cname superclasses slots options-and-doc) | |
412 | ;; FIXME: Most of this should be moved to the `defclass' macro. | |
413 | "Define CNAME as a new subclass of SUPERCLASSES. | |
414 | SLOTS are the slots residing in that class definition, and options or | |
415 | documentation OPTIONS-AND-DOC is the toplevel documentation for this class. | |
416 | See `defclass' for more information." | |
417 | ;; Run our eieio-hook each time, and clear it when we are done. | |
418 | ;; This way people can add hooks safely if they want to modify eieio | |
419 | ;; or add definitions when eieio is loaded or something like that. | |
420 | (run-hooks 'eieio-hook) | |
421 | (setq eieio-hook nil) | |
422 | ||
423 | (eieio--check-type listp superclasses) | |
424 | ||
425 | (let* ((pname superclasses) | |
426 | (newc (make-vector eieio--class-num-slots nil)) | |
427 | (oldc (when (class-p cname) (class-v cname))) | |
428 | (groups nil) ;; list of groups id'd from slots | |
429 | (options nil) | |
430 | (clearparent nil)) | |
431 | ||
432 | (aset newc 0 'defclass) | |
433 | (setf (eieio--class-symbol newc) cname) | |
434 | ||
435 | ;; If this class already existed, and we are updating its structure, | |
436 | ;; make sure we keep the old child list. This can cause bugs, but | |
437 | ;; if no new slots are created, it also saves time, and prevents | |
438 | ;; method table breakage, particularly when the users is only | |
439 | ;; byte compiling an EIEIO file. | |
440 | (if oldc | |
441 | (setf (eieio--class-children newc) (eieio--class-children oldc)) | |
442 | ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. | |
443 | ;; This is like the above, but deals with autoloads nicely. | |
444 | (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) | |
445 | (when sym | |
446 | (condition-case nil | |
447 | (setf (eieio--class-children newc) (symbol-value sym)) | |
448 | (error nil)) | |
449 | (unintern (symbol-name cname) eieio-defclass-autoload-map) | |
450 | )) | |
451 | ) | |
452 | ||
453 | (cond ((and (stringp (car options-and-doc)) | |
454 | (/= 1 (% (length options-and-doc) 2))) | |
455 | (error "Too many arguments to `defclass'")) | |
456 | ((and (symbolp (car options-and-doc)) | |
457 | (/= 0 (% (length options-and-doc) 2))) | |
458 | (error "Too many arguments to `defclass'")) | |
459 | ) | |
460 | ||
461 | (setq options | |
462 | (if (stringp (car options-and-doc)) | |
463 | (cons :documentation options-and-doc) | |
464 | options-and-doc)) | |
465 | ||
466 | (if pname | |
467 | (progn | |
468 | (while pname | |
469 | (if (and (car pname) (symbolp (car pname))) | |
470 | (if (not (class-p (car pname))) | |
471 | ;; bad class | |
472 | (error "Given parent class %s is not a class" (car pname)) | |
473 | ;; good parent class... | |
474 | ;; save new child in parent | |
475 | (when (not (member cname (eieio--class-children (class-v (car pname))))) | |
476 | (setf (eieio--class-children (class-v (car pname))) | |
477 | (cons cname (eieio--class-children (class-v (car pname)))))) | |
478 | ;; Get custom groups, and store them into our local copy. | |
479 | (mapc (lambda (g) (pushnew g groups :test #'equal)) | |
480 | (class-option (car pname) :custom-groups)) | |
481 | ;; save parent in child | |
482 | (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) | |
483 | (error "Invalid parent class %s" pname)) | |
484 | (setq pname (cdr pname))) | |
485 | ;; Reverse the list of our parents so that they are prioritized in | |
486 | ;; the same order as specified in the code. | |
487 | (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) | |
488 | ;; If there is nothing to loop over, then inherit from the | |
489 | ;; default superclass. | |
490 | (unless (eq cname 'eieio-default-superclass) | |
491 | ;; adopt the default parent here, but clear it later... | |
492 | (setq clearparent t) | |
493 | ;; save new child in parent | |
494 | (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) | |
495 | (setf (eieio--class-children (class-v 'eieio-default-superclass)) | |
496 | (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) | |
497 | ;; save parent in child | |
498 | (setf (eieio--class-parent newc) (list eieio-default-superclass)))) | |
499 | ||
500 | ;; turn this into a usable self-pointing symbol | |
501 | (set cname cname) | |
502 | ||
503 | ;; These two tests must be created right away so we can have self- | |
504 | ;; referencing classes. ei, a class whose slot can contain only | |
505 | ;; pointers to itself. | |
506 | ||
507 | ;; Create the test function | |
508 | (let ((csym (intern (concat (symbol-name cname) "-p")))) | |
509 | (fset csym | |
510 | (list 'lambda (list 'obj) | |
511 | (format "Test OBJ to see if it an object of type %s" cname) | |
512 | (list 'and '(eieio-object-p obj) | |
513 | (list 'same-class-p 'obj cname))))) | |
514 | ||
515 | ;; Make sure the method invocation order is a valid value. | |
516 | (let ((io (class-option-assoc options :method-invocation-order))) | |
517 | (when (and io (not (member io '(:depth-first :breadth-first :c3)))) | |
518 | (error "Method invocation order %s is not allowed" io) | |
519 | )) | |
520 | ||
521 | ;; Create a handy child test too | |
522 | (let ((csym (intern (concat (symbol-name cname) "-child-p")))) | |
523 | (fset csym | |
524 | `(lambda (obj) | |
525 | ,(format | |
526 | "Test OBJ to see if it an object is a child of type %s" | |
527 | cname) | |
528 | (and (eieio-object-p obj) | |
529 | (object-of-class-p obj ,cname)))) | |
530 | ||
531 | ;; Create a handy list of the class test too | |
532 | (let ((csym (intern (concat (symbol-name cname) "-list-p")))) | |
533 | (fset csym | |
534 | `(lambda (obj) | |
535 | ,(format | |
536 | "Test OBJ to see if it a list of objects which are a child of type %s" | |
537 | cname) | |
538 | (when (listp obj) | |
539 | (let ((ans t)) ;; nil is valid | |
540 | ;; Loop over all the elements of the input list, test | |
541 | ;; each to make sure it is a child of the desired object class. | |
542 | (while (and obj ans) | |
543 | (setq ans (and (eieio-object-p (car obj)) | |
544 | (object-of-class-p (car obj) ,cname))) | |
545 | (setq obj (cdr obj))) | |
546 | ans))))) | |
547 | ||
548 | ;; When using typep, (typep OBJ 'myclass) returns t for objects which | |
549 | ;; are subclasses of myclass. For our predicates, however, it is | |
550 | ;; important for EIEIO to be backwards compatible, where | |
551 | ;; myobject-p, and myobject-child-p are different. | |
552 | ;; "cl" uses this technique to specify symbols with specific typep | |
553 | ;; test, so we can let typep have the CLOS documented behavior | |
554 | ;; while keeping our above predicate clean. | |
555 | ||
556 | ;; It would be cleaner to use `defsetf' here, but that requires cl | |
557 | ;; at runtime. | |
558 | (put cname 'cl-deftype-handler | |
559 | (list 'lambda () `(list 'satisfies (quote ,csym))))) | |
560 | ||
561 | ;; Before adding new slots, let's add all the methods and classes | |
562 | ;; in from the parent class. | |
563 | (eieio-copy-parents-into-subclass newc superclasses) | |
564 | ||
565 | ;; Store the new class vector definition into the symbol. We need to | |
566 | ;; do this first so that we can call defmethod for the accessor. | |
567 | ;; The vector will be updated by the following while loop and will not | |
568 | ;; need to be stored a second time. | |
569 | (put cname 'eieio-class-definition newc) | |
570 | ||
571 | ;; Query each slot in the declaration list and mangle into the | |
572 | ;; class structure I have defined. | |
573 | (while slots | |
574 | (let* ((slot1 (car slots)) | |
575 | (name (car slot1)) | |
576 | (slot (cdr slot1)) | |
577 | (acces (plist-get slot ':accessor)) | |
578 | (init (or (plist-get slot ':initform) | |
579 | (if (member ':initform slot) nil | |
580 | eieio-unbound))) | |
581 | (initarg (plist-get slot ':initarg)) | |
582 | (docstr (plist-get slot ':documentation)) | |
583 | (prot (plist-get slot ':protection)) | |
584 | (reader (plist-get slot ':reader)) | |
585 | (writer (plist-get slot ':writer)) | |
586 | (alloc (plist-get slot ':allocation)) | |
587 | (type (plist-get slot ':type)) | |
588 | (custom (plist-get slot ':custom)) | |
589 | (label (plist-get slot ':label)) | |
590 | (customg (plist-get slot ':group)) | |
591 | (printer (plist-get slot ':printer)) | |
592 | ||
593 | (skip-nil (class-option-assoc options :allow-nil-initform)) | |
594 | ) | |
595 | ||
596 | (if eieio-error-unsupported-class-tags | |
597 | (let ((tmp slot)) | |
598 | (while tmp | |
599 | (if (not (member (car tmp) '(:accessor | |
600 | :initform | |
601 | :initarg | |
602 | :documentation | |
603 | :protection | |
604 | :reader | |
605 | :writer | |
606 | :allocation | |
607 | :type | |
608 | :custom | |
609 | :label | |
610 | :group | |
611 | :printer | |
612 | :allow-nil-initform | |
613 | :custom-groups))) | |
614 | (signal 'invalid-slot-type (list (car tmp)))) | |
615 | (setq tmp (cdr (cdr tmp)))))) | |
616 | ||
617 | ;; Clean up the meaning of protection. | |
618 | (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) | |
619 | ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) | |
620 | ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) | |
621 | ((eq prot nil) nil) | |
622 | (t (signal 'invalid-slot-type (list ':protection prot)))) | |
623 | ||
624 | ;; Make sure the :allocation parameter has a valid value. | |
625 | (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) | |
626 | (signal 'invalid-slot-type (list ':allocation alloc))) | |
627 | ||
628 | ;; The default type specifier is supposed to be t, meaning anything. | |
629 | (if (not type) (setq type t)) | |
630 | ||
631 | ;; Label is nil, or a string | |
632 | (if (not (or (null label) (stringp label))) | |
633 | (signal 'invalid-slot-type (list ':label label))) | |
634 | ||
635 | ;; Is there an initarg, but allocation of class? | |
636 | (if (and initarg (eq alloc :class)) | |
637 | (message "Class allocated slots do not need :initarg")) | |
638 | ||
639 | ;; intern the symbol so we can use it blankly | |
640 | (if initarg (set initarg initarg)) | |
641 | ||
642 | ;; The customgroup should be a list of symbols | |
643 | (cond ((null customg) | |
644 | (setq customg '(default))) | |
645 | ((not (listp customg)) | |
646 | (setq customg (list customg)))) | |
647 | ;; The customgroup better be a symbol, or list of symbols. | |
648 | (mapc (lambda (cg) | |
649 | (if (not (symbolp cg)) | |
650 | (signal 'invalid-slot-type (list ':group cg)))) | |
651 | customg) | |
652 | ||
653 | ;; First up, add this slot into our new class. | |
654 | (eieio-add-new-slot newc name init docstr type custom label customg printer | |
655 | prot initarg alloc 'defaultoverride skip-nil) | |
656 | ||
657 | ;; We need to id the group, and store them in a group list attribute. | |
658 | (mapc (lambda (cg) (pushnew cg groups :test 'equal)) customg) | |
659 | ||
660 | ;; Anyone can have an accessor function. This creates a function | |
661 | ;; of the specified name, and also performs a `defsetf' if applicable | |
662 | ;; so that users can `setf' the space returned by this function. | |
663 | (if acces | |
664 | (progn | |
665 | (eieio--defmethod | |
666 | acces (if (eq alloc :class) :static :primary) cname | |
667 | `(lambda (this) | |
668 | ,(format | |
669 | "Retrieves the slot `%s' from an object of class `%s'" | |
670 | name cname) | |
671 | (if (slot-boundp this ',name) | |
672 | (eieio-oref this ',name) | |
673 | ;; Else - Some error? nil? | |
674 | nil))) | |
675 | ||
676 | (if (fboundp 'gv-define-setter) | |
677 | ;; FIXME: We should move more of eieio-defclass into the | |
678 | ;; defclass macro so we don't have to use `eval' and require | |
679 | ;; `gv' at run-time. | |
680 | (eval `(gv-define-setter ,acces (eieio--store eieio--object) | |
681 | (list 'eieio-oset eieio--object '',name | |
682 | eieio--store))) | |
683 | ;; Provide a setf method. It would be cleaner to use | |
684 | ;; defsetf, but that would require CL at runtime. | |
685 | (put acces 'setf-method | |
686 | `(lambda (widget) | |
687 | (let* ((--widget-sym-- (make-symbol "--widget--")) | |
688 | (--store-sym-- (make-symbol "--store--"))) | |
689 | (list | |
690 | (list --widget-sym--) | |
691 | (list widget) | |
692 | (list --store-sym--) | |
693 | (list 'eieio-oset --widget-sym-- '',name | |
694 | --store-sym--) | |
695 | (list 'getfoo --widget-sym--)))))))) | |
696 | ||
697 | ;; If a writer is defined, then create a generic method of that | |
698 | ;; name whose purpose is to set the value of the slot. | |
699 | (if writer | |
700 | (eieio--defmethod | |
701 | writer nil cname | |
702 | `(lambda (this value) | |
703 | ,(format "Set the slot `%s' of an object of class `%s'" | |
704 | name cname) | |
705 | (setf (slot-value this ',name) value)))) | |
706 | ;; If a reader is defined, then create a generic method | |
707 | ;; of that name whose purpose is to access this slot value. | |
708 | (if reader | |
709 | (eieio--defmethod | |
710 | reader nil cname | |
711 | `(lambda (this) | |
712 | ,(format "Access the slot `%s' from object of class `%s'" | |
713 | name cname) | |
714 | (slot-value this ',name)))) | |
715 | ) | |
716 | (setq slots (cdr slots))) | |
717 | ||
718 | ;; Now that everything has been loaded up, all our lists are backwards! | |
719 | ;; Fix that up now. | |
720 | (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) | |
721 | (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) | |
722 | (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) | |
723 | (setf (eieio--class-public-type newc) | |
724 | (apply 'vector (nreverse (eieio--class-public-type newc)))) | |
725 | (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) | |
726 | (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) | |
727 | (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) | |
728 | (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) | |
729 | (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) | |
730 | (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) | |
731 | ||
732 | ;; The storage for class-class-allocation-type needs to be turned into | |
733 | ;; a vector now. | |
734 | (setf (eieio--class-class-allocation-type newc) | |
735 | (apply 'vector (eieio--class-class-allocation-type newc))) | |
736 | ||
737 | ;; Also, take class allocated values, and vectorize them for speed. | |
738 | (setf (eieio--class-class-allocation-values newc) | |
739 | (apply 'vector (eieio--class-class-allocation-values newc))) | |
740 | ||
741 | ;; Attach slot symbols into an obarray, and store the index of | |
742 | ;; this slot as the variable slot in this new symbol. We need to | |
743 | ;; know about primes, because obarrays are best set in vectors of | |
744 | ;; prime number length, and we also need to make our vector small | |
745 | ;; to save space, and also optimal for the number of items we have. | |
746 | (let* ((cnt 0) | |
747 | (pubsyms (eieio--class-public-a newc)) | |
748 | (prots (eieio--class-protection newc)) | |
749 | (l (length pubsyms)) | |
750 | (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 | |
751 | 53 59 61 67 71 73 79 83 89 97 101 ))) | |
752 | (while (and primes (< (car primes) l)) | |
753 | (setq primes (cdr primes))) | |
754 | (car primes))) | |
755 | (oa (make-vector vl 0)) | |
756 | (newsym)) | |
757 | (while pubsyms | |
758 | (setq newsym (intern (symbol-name (car pubsyms)) oa)) | |
759 | (set newsym cnt) | |
760 | (setq cnt (1+ cnt)) | |
761 | (if (car prots) (put newsym 'protection (car prots))) | |
762 | (setq pubsyms (cdr pubsyms) | |
763 | prots (cdr prots))) | |
764 | (setf (eieio--class-symbol-obarray newc) oa) | |
765 | ) | |
766 | ||
767 | ;; Create the constructor function | |
768 | (if (class-option-assoc options :abstract) | |
769 | ;; Abstract classes cannot be instantiated. Say so. | |
770 | (let ((abs (class-option-assoc options :abstract))) | |
771 | (if (not (stringp abs)) | |
772 | (setq abs (format "Class %s is abstract" cname))) | |
773 | (fset cname | |
774 | `(lambda (&rest stuff) | |
775 | ,(format "You cannot create a new object of type %s" cname) | |
776 | (error ,abs)))) | |
777 | ||
778 | ;; Non-abstract classes need a constructor. | |
779 | (fset cname | |
780 | `(lambda (newname &rest slots) | |
781 | ,(format "Create a new object with name NAME of class type %s" cname) | |
782 | (apply 'constructor ,cname newname slots))) | |
783 | ) | |
784 | ||
785 | ;; Set up a specialized doc string. | |
786 | ;; Use stored value since it is calculated in a non-trivial way | |
787 | (put cname 'variable-documentation | |
788 | (class-option-assoc options :documentation)) | |
789 | ||
790 | ;; Save the file location where this class is defined. | |
791 | (let ((fname (if load-in-progress | |
792 | load-file-name | |
793 | buffer-file-name))) | |
794 | (when fname | |
795 | (when (string-match "\\.elc\\'" fname) | |
796 | (setq fname (substring fname 0 (1- (length fname))))) | |
797 | (put cname 'class-location fname))) | |
798 | ||
799 | ;; We have a list of custom groups. Store them into the options. | |
800 | (let ((g (class-option-assoc options :custom-groups))) | |
801 | (mapc (lambda (cg) (pushnew cg g :test 'equal)) groups) | |
802 | (if (memq :custom-groups options) | |
803 | (setcar (cdr (memq :custom-groups options)) g) | |
804 | (setq options (cons :custom-groups (cons g options))))) | |
805 | ||
806 | ;; Set up the options we have collected. | |
807 | (setf (eieio--class-options newc) options) | |
808 | ||
809 | ;; if this is a superclass, clear out parent (which was set to the | |
810 | ;; default superclass eieio-default-superclass) | |
811 | (if clearparent (setf (eieio--class-parent newc) nil)) | |
812 | ||
813 | ;; Create the cached default object. | |
814 | (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) | |
815 | nil))) | |
816 | (aset cache 0 'object) | |
817 | (setf (eieio--object-class cache) cname) | |
818 | (setf (eieio--object-name cache) 'default-cache-object) | |
819 | (let ((eieio-skip-typecheck t)) | |
820 | ;; All type-checking has been done to our satisfaction | |
821 | ;; before this call. Don't waste our time in this call.. | |
822 | (eieio-set-defaults cache t)) | |
823 | (setf (eieio--class-default-object-cache newc) cache)) | |
824 | ||
825 | ;; Return our new class object | |
826 | ;; newc | |
827 | cname | |
828 | )) | |
829 | ||
830 | (defsubst eieio-eval-default-p (val) | |
831 | "Whether the default value VAL should be evaluated for use." | |
832 | (and (consp val) (symbolp (car val)) (fboundp (car val)))) | |
833 | ||
834 | (defun eieio-perform-slot-validation-for-default (slot spec value skipnil) | |
835 | "For SLOT, signal if SPEC does not match VALUE. | |
836 | If SKIPNIL is non-nil, then if VALUE is nil return t instead." | |
837 | (if (and (not (eieio-eval-default-p value)) | |
838 | (not eieio-skip-typecheck) | |
839 | (not (and skipnil (null value))) | |
840 | (not (eieio-perform-slot-validation spec value))) | |
841 | (signal 'invalid-slot-type (list slot spec value)))) | |
842 | ||
843 | (defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc | |
844 | &optional defaultoverride skipnil) | |
845 | "Add into NEWC attribute A. | |
846 | If A already exists in NEWC, then do nothing. If it doesn't exist, | |
847 | then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. | |
848 | Argument ALLOC specifies if the slot is allocated per instance, or per class. | |
849 | If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, | |
850 | we must override its value for a default. | |
851 | Optional argument SKIPNIL indicates if type checking should be skipped | |
852 | if default value is nil." | |
853 | ;; Make sure we duplicate those items that are sequences. | |
854 | (condition-case nil | |
855 | (if (sequencep d) (setq d (copy-sequence d))) | |
856 | ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. | |
857 | (error nil)) | |
858 | (if (sequencep type) (setq type (copy-sequence type))) | |
859 | (if (sequencep cust) (setq cust (copy-sequence cust))) | |
860 | (if (sequencep custg) (setq custg (copy-sequence custg))) | |
861 | ||
862 | ;; To prevent override information w/out specification of storage, | |
863 | ;; we need to do this little hack. | |
864 | (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) | |
865 | ||
866 | (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) | |
867 | ;; In this case, we modify the INSTANCE version of a given slot. | |
868 | ||
869 | (progn | |
870 | ||
871 | ;; Only add this element if it is so-far unique | |
872 | (if (not (member a (eieio--class-public-a newc))) | |
873 | (progn | |
874 | (eieio-perform-slot-validation-for-default a type d skipnil) | |
875 | (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) | |
876 | (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) | |
877 | (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) | |
878 | (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) | |
879 | (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) | |
880 | (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) | |
881 | (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) | |
882 | (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) | |
883 | (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) | |
884 | (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) | |
885 | ) | |
886 | ;; When defaultoverride is true, we are usually adding new local | |
887 | ;; attributes which must override the default value of any slot | |
888 | ;; passed in by one of the parent classes. | |
889 | (when defaultoverride | |
890 | ;; There is a match, and we must override the old value. | |
891 | (let* ((ca (eieio--class-public-a newc)) | |
892 | (np (member a ca)) | |
893 | (num (- (length ca) (length np))) | |
894 | (dp (if np (nthcdr num (eieio--class-public-d newc)) | |
895 | nil)) | |
896 | (tp (if np (nth num (eieio--class-public-type newc)))) | |
897 | ) | |
898 | (if (not np) | |
899 | (error "EIEIO internal error overriding default value for %s" | |
900 | a) | |
901 | ;; If type is passed in, is it the same? | |
902 | (if (not (eq type t)) | |
903 | (if (not (equal type tp)) | |
904 | (error | |
905 | "Child slot type `%s' does not match inherited type `%s' for `%s'" | |
906 | type tp a))) | |
907 | ;; If we have a repeat, only update the initarg... | |
908 | (unless (eq d eieio-unbound) | |
909 | (eieio-perform-slot-validation-for-default a tp d skipnil) | |
910 | (setcar dp d)) | |
911 | ;; If we have a new initarg, check for it. | |
912 | (when init | |
913 | (let* ((inits (eieio--class-initarg-tuples newc)) | |
914 | (inita (rassq a inits))) | |
915 | ;; Replace the CAR of the associate INITA. | |
916 | ;;(message "Initarg: %S replace %s" inita init) | |
917 | (setcar inita init) | |
918 | )) | |
919 | ||
920 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is | |
921 | ;; checked and SHOULD match the superclass | |
922 | ;; protection. Otherwise an error is thrown. However | |
923 | ;; I wonder if a more flexible schedule might be | |
924 | ;; implemented. | |
925 | ;; | |
926 | ;; EML - We used to have (if prot... here, | |
927 | ;; but a prot of 'nil means public. | |
928 | ;; | |
929 | (let ((super-prot (nth num (eieio--class-protection newc))) | |
930 | ) | |
931 | (if (not (eq prot super-prot)) | |
932 | (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" | |
933 | prot super-prot a))) | |
934 | ;; End original PLN | |
935 | ||
936 | ;; PLN Tue Jun 26 11:57:06 2007 : | |
937 | ;; Do a non redundant combination of ancient custom | |
938 | ;; groups and new ones. | |
939 | (when custg | |
940 | (let* ((groups | |
941 | (nthcdr num (eieio--class-public-custom-group newc))) | |
942 | (list1 (car groups)) | |
943 | (list2 (if (listp custg) custg (list custg)))) | |
944 | (if (< (length list1) (length list2)) | |
945 | (setq list1 (prog1 list2 (setq list2 list1)))) | |
946 | (dolist (elt list2) | |
947 | (unless (memq elt list1) | |
948 | (push elt list1))) | |
949 | (setcar groups list1))) | |
950 | ;; End PLN | |
951 | ||
952 | ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is | |
953 | ;; set, simply replaces the old one. | |
954 | (when cust | |
955 | ;; (message "Custom type redefined to %s" cust) | |
956 | (setcar (nthcdr num (eieio--class-public-custom newc)) cust)) | |
957 | ||
958 | ;; If a new label is specified, it simply replaces | |
959 | ;; the old one. | |
960 | (when label | |
961 | ;; (message "Custom label redefined to %s" label) | |
962 | (setcar (nthcdr num (eieio--class-public-custom-label newc)) label)) | |
963 | ;; End PLN | |
964 | ||
965 | ;; PLN Sat Jun 30 17:24:42 2007 : when a new | |
966 | ;; doc is specified, simply replaces the old one. | |
967 | (when doc | |
968 | ;;(message "Documentation redefined to %s" doc) | |
969 | (setcar (nthcdr num (eieio--class-public-doc newc)) | |
970 | doc)) | |
971 | ;; End PLN | |
972 | ||
973 | ;; If a new printer is specified, it simply replaces | |
974 | ;; the old one. | |
975 | (when print | |
976 | ;; (message "printer redefined to %s" print) | |
977 | (setcar (nthcdr num (eieio--class-public-printer newc)) print)) | |
978 | ||
979 | ))) | |
980 | )) | |
981 | ||
982 | ;; CLASS ALLOCATED SLOTS | |
983 | (let ((value (eieio-default-eval-maybe d))) | |
984 | (if (not (member a (eieio--class-class-allocation-a newc))) | |
985 | (progn | |
986 | (eieio-perform-slot-validation-for-default a type value skipnil) | |
987 | ;; Here we have found a :class version of a slot. This | |
988 | ;; requires a very different approach. | |
989 | (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) | |
990 | (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) | |
991 | (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) | |
992 | (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) | |
993 | (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) | |
994 | (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) | |
995 | (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) | |
996 | ;; Default value is stored in the 'values section, since new objects | |
997 | ;; can't initialize from this element. | |
998 | (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) | |
999 | (when defaultoverride | |
1000 | ;; There is a match, and we must override the old value. | |
1001 | (let* ((ca (eieio--class-class-allocation-a newc)) | |
1002 | (np (member a ca)) | |
1003 | (num (- (length ca) (length np))) | |
1004 | (dp (if np | |
1005 | (nthcdr num | |
1006 | (eieio--class-class-allocation-values newc)) | |
1007 | nil)) | |
1008 | (tp (if np (nth num (eieio--class-class-allocation-type newc)) | |
1009 | nil))) | |
1010 | (if (not np) | |
1011 | (error "EIEIO internal error overriding default value for %s" | |
1012 | a) | |
1013 | ;; If type is passed in, is it the same? | |
1014 | (if (not (eq type t)) | |
1015 | (if (not (equal type tp)) | |
1016 | (error | |
1017 | "Child slot type `%s' does not match inherited type `%s' for `%s'" | |
1018 | type tp a))) | |
1019 | ;; EML - Note: the only reason to override a class bound slot | |
1020 | ;; is to change the default, so allow unbound in. | |
1021 | ||
1022 | ;; If we have a repeat, only update the value... | |
1023 | (eieio-perform-slot-validation-for-default a tp value skipnil) | |
1024 | (setcar dp value)) | |
1025 | ||
1026 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is | |
1027 | ;; checked and SHOULD match the superclass | |
1028 | ;; protection. Otherwise an error is thrown. However | |
1029 | ;; I wonder if a more flexible schedule might be | |
1030 | ;; implemented. | |
1031 | (let ((super-prot | |
1032 | (car (nthcdr num (eieio--class-class-allocation-protection newc))))) | |
1033 | (if (not (eq prot super-prot)) | |
1034 | (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" | |
1035 | prot super-prot a))) | |
1036 | ;; Do a non redundant combination of ancient custom groups | |
1037 | ;; and new ones. | |
1038 | (when custg | |
1039 | (let* ((groups | |
1040 | (nthcdr num (eieio--class-class-allocation-custom-group newc))) | |
1041 | (list1 (car groups)) | |
1042 | (list2 (if (listp custg) custg (list custg)))) | |
1043 | (if (< (length list1) (length list2)) | |
1044 | (setq list1 (prog1 list2 (setq list2 list1)))) | |
1045 | (dolist (elt list2) | |
1046 | (unless (memq elt list1) | |
1047 | (push elt list1))) | |
1048 | (setcar groups list1))) | |
1049 | ||
1050 | ;; PLN Sat Jun 30 17:24:42 2007 : when a new | |
1051 | ;; doc is specified, simply replaces the old one. | |
1052 | (when doc | |
1053 | ;;(message "Documentation redefined to %s" doc) | |
1054 | (setcar (nthcdr num (eieio--class-class-allocation-doc newc)) | |
1055 | doc)) | |
1056 | ;; End PLN | |
1057 | ||
1058 | ;; If a new printer is specified, it simply replaces | |
1059 | ;; the old one. | |
1060 | (when print | |
1061 | ;; (message "printer redefined to %s" print) | |
1062 | (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print)) | |
1063 | ||
1064 | )) | |
1065 | )) | |
1066 | )) | |
1067 | ||
1068 | (defun eieio-copy-parents-into-subclass (newc parents) | |
1069 | "Copy into NEWC the slots of PARENTS. | |
1070 | Follow the rules of not overwriting early parents when applying to | |
1071 | the new child class." | |
1072 | (let ((ps (eieio--class-parent newc)) | |
1073 | (sn (class-option-assoc (eieio--class-options newc) | |
1074 | ':allow-nil-initform))) | |
1075 | (while ps | |
1076 | ;; First, duplicate all the slots of the parent. | |
1077 | (let ((pcv (class-v (car ps)))) | |
1078 | (let ((pa (eieio--class-public-a pcv)) | |
1079 | (pd (eieio--class-public-d pcv)) | |
1080 | (pdoc (eieio--class-public-doc pcv)) | |
1081 | (ptype (eieio--class-public-type pcv)) | |
1082 | (pcust (eieio--class-public-custom pcv)) | |
1083 | (plabel (eieio--class-public-custom-label pcv)) | |
1084 | (pcustg (eieio--class-public-custom-group pcv)) | |
1085 | (printer (eieio--class-public-printer pcv)) | |
1086 | (pprot (eieio--class-protection pcv)) | |
1087 | (pinit (eieio--class-initarg-tuples pcv)) | |
1088 | (i 0)) | |
1089 | (while pa | |
1090 | (eieio-add-new-slot newc | |
1091 | (car pa) (car pd) (car pdoc) (aref ptype i) | |
1092 | (car pcust) (car plabel) (car pcustg) | |
1093 | (car printer) | |
1094 | (car pprot) (car-safe (car pinit)) nil nil sn) | |
1095 | ;; Increment each value. | |
1096 | (setq pa (cdr pa) | |
1097 | pd (cdr pd) | |
1098 | pdoc (cdr pdoc) | |
1099 | i (1+ i) | |
1100 | pcust (cdr pcust) | |
1101 | plabel (cdr plabel) | |
1102 | pcustg (cdr pcustg) | |
1103 | printer (cdr printer) | |
1104 | pprot (cdr pprot) | |
1105 | pinit (cdr pinit)) | |
1106 | )) ;; while/let | |
1107 | ;; Now duplicate all the class alloc slots. | |
1108 | (let ((pa (eieio--class-class-allocation-a pcv)) | |
1109 | (pdoc (eieio--class-class-allocation-doc pcv)) | |
1110 | (ptype (eieio--class-class-allocation-type pcv)) | |
1111 | (pcust (eieio--class-class-allocation-custom pcv)) | |
1112 | (plabel (eieio--class-class-allocation-custom-label pcv)) | |
1113 | (pcustg (eieio--class-class-allocation-custom-group pcv)) | |
1114 | (printer (eieio--class-class-allocation-printer pcv)) | |
1115 | (pprot (eieio--class-class-allocation-protection pcv)) | |
1116 | (pval (eieio--class-class-allocation-values pcv)) | |
1117 | (i 0)) | |
1118 | (while pa | |
1119 | (eieio-add-new-slot newc | |
1120 | (car pa) (aref pval i) (car pdoc) (aref ptype i) | |
1121 | (car pcust) (car plabel) (car pcustg) | |
1122 | (car printer) | |
1123 | (car pprot) nil ':class sn) | |
1124 | ;; Increment each value. | |
1125 | (setq pa (cdr pa) | |
1126 | pdoc (cdr pdoc) | |
1127 | pcust (cdr pcust) | |
1128 | plabel (cdr plabel) | |
1129 | pcustg (cdr pcustg) | |
1130 | printer (cdr printer) | |
1131 | pprot (cdr pprot) | |
1132 | i (1+ i)) | |
1133 | ))) ;; while/let | |
1134 | ;; Loop over each parent class | |
1135 | (setq ps (cdr ps))) | |
1136 | )) | |
1137 | ||
1138 | \f | |
1139 | ;;; CLOS methods and generics | |
1140 | ;; | |
1141 | ||
1142 | (defun eieio--defgeneric-init-form (method doc-string) | |
1143 | "Form to use for the initial definition of a generic." | |
1144 | (cond | |
1145 | ((or (not (fboundp method)) | |
1146 | (eq 'autoload (car-safe (symbol-function method)))) | |
1147 | ;; Make sure the method tables are installed. | |
1148 | (eieiomt-install method) | |
1149 | ;; Construct the actual body of this function. | |
1150 | (eieio-defgeneric-form method doc-string)) | |
1151 | ((generic-p method) (symbol-function method)) ;Leave it as-is. | |
1152 | (t (error "You cannot create a generic/method over an existing symbol: %s" | |
1153 | method)))) | |
1154 | ||
1155 | (defun eieio-defgeneric-form (method doc-string) | |
1156 | "The lambda form that would be used as the function defined on METHOD. | |
1157 | All methods should call the same EIEIO function for dispatch. | |
1158 | DOC-STRING is the documentation attached to METHOD." | |
1159 | `(lambda (&rest local-args) | |
1160 | ,doc-string | |
1161 | (eieio-generic-call (quote ,method) local-args))) | |
1162 | ||
1163 | (defsubst eieio-defgeneric-reset-generic-form (method) | |
1164 | "Setup METHOD to call the generic form." | |
1165 | (let ((doc-string (documentation method))) | |
1166 | (fset method (eieio-defgeneric-form method doc-string)))) | |
1167 | ||
1168 | (defun eieio-defgeneric-form-primary-only (method doc-string) | |
1169 | "The lambda form that would be used as the function defined on METHOD. | |
1170 | All methods should call the same EIEIO function for dispatch. | |
1171 | DOC-STRING is the documentation attached to METHOD." | |
1172 | `(lambda (&rest local-args) | |
1173 | ,doc-string | |
1174 | (eieio-generic-call-primary-only (quote ,method) local-args))) | |
1175 | ||
1176 | (defsubst eieio-defgeneric-reset-generic-form-primary-only (method) | |
1177 | "Setup METHOD to call the generic form." | |
1178 | (let ((doc-string (documentation method))) | |
1179 | (fset method (eieio-defgeneric-form-primary-only method doc-string)))) | |
1180 | ||
1181 | (defun eieio-defgeneric-form-primary-only-one (method doc-string | |
1182 | class | |
1183 | impl | |
1184 | ) | |
1185 | "The lambda form that would be used as the function defined on METHOD. | |
1186 | All methods should call the same EIEIO function for dispatch. | |
1187 | DOC-STRING is the documentation attached to METHOD. | |
1188 | CLASS is the class symbol needed for private method access. | |
1189 | IMPL is the symbol holding the method implementation." | |
1190 | ;; NOTE: I tried out byte compiling this little fcn. Turns out it | |
1191 | ;; is faster to execute this for not byte-compiled. ie, install this, | |
1192 | ;; then measure calls going through here. I wonder why. | |
1193 | (require 'bytecomp) | |
1194 | (let ((byte-compile-warnings nil)) | |
1195 | (byte-compile | |
1196 | `(lambda (&rest local-args) | |
1197 | ,doc-string | |
1198 | ;; This is a cool cheat. Usually we need to look up in the | |
1199 | ;; method table to find out if there is a method or not. We can | |
1200 | ;; instead make that determination at load time when there is | |
1201 | ;; only one method. If the first arg is not a child of the class | |
1202 | ;; of that one implementation, then clearly, there is no method def. | |
1203 | (if (not (eieio-object-p (car local-args))) | |
1204 | ;; Not an object. Just signal. | |
1205 | (signal 'no-method-definition | |
1206 | (list ',method local-args)) | |
1207 | ||
1208 | ;; We do have an object. Make sure it is the right type. | |
1209 | (if ,(if (eq class eieio-default-superclass) | |
1210 | nil ; default superclass means just an obj. Already asked. | |
1211 | `(not (child-of-class-p (eieio--object-class (car local-args)) | |
1212 | ',class))) | |
1213 | ||
1214 | ;; If not the right kind of object, call no applicable | |
1215 | (apply 'no-applicable-method (car local-args) | |
1216 | ',method local-args) | |
1217 | ||
1218 | ;; It is ok, do the call. | |
1219 | ;; Fill in inter-call variables then evaluate the method. | |
1220 | (let ((eieio-generic-call-next-method-list nil) | |
1221 | (eieio-generic-call-key method-primary) | |
1222 | (eieio-generic-call-methodname ',method) | |
1223 | (eieio-generic-call-arglst local-args) | |
1224 | ) | |
1225 | (eieio--with-scoped-class ',class | |
1226 | ,(if (< emacs-major-version 24) | |
1227 | `(apply ,(list 'quote impl) local-args) | |
1228 | `(apply #',impl local-args))) | |
1229 | ;(,impl local-args) | |
1230 | ))))))) | |
1231 | ||
1232 | (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) | |
1233 | "Setup METHOD to call the generic form." | |
1234 | (let* ((doc-string (documentation method)) | |
1235 | (M (get method 'eieio-method-tree)) | |
1236 | (entry (car (aref M method-primary))) | |
1237 | ) | |
1238 | (fset method (eieio-defgeneric-form-primary-only-one | |
1239 | method doc-string | |
1240 | (car entry) | |
1241 | (cdr entry) | |
1242 | )))) | |
1243 | ||
1244 | (defun eieio-unbind-method-implementations (method) | |
1245 | "Make the generic method METHOD have no implementations. | |
1246 | It will leave the original generic function in place, | |
1247 | but remove reference to all implementations of METHOD." | |
1248 | (put method 'eieio-method-tree nil) | |
1249 | (put method 'eieio-method-obarray nil)) | |
1250 | ||
1251 | (defun eieio--defmethod (method kind argclass code) | |
1252 | "Work part of the `defmethod' macro defining METHOD with ARGS." | |
1253 | (let ((key | |
1254 | ;; Find optional keys. | |
1255 | (cond ((memq kind '(:BEFORE :before)) method-before) | |
1256 | ((memq kind '(:AFTER :after)) method-after) | |
1257 | ((memq kind '(:STATIC :static)) method-static) | |
1258 | ((memq kind '(:PRIMARY :primary nil)) method-primary) | |
1259 | ;; Primary key. | |
1260 | ;; (t method-primary) | |
1261 | (t (error "Unknown method kind %S" kind))))) | |
1262 | ;; Make sure there is a generic (when called from defclass). | |
1263 | (eieio--defalias | |
1264 | method (eieio--defgeneric-init-form | |
1265 | method (or (documentation code) | |
1266 | (format "Generically created method `%s'." method)))) | |
1267 | ;; Create symbol for property to bind to. If the first arg is of | |
1268 | ;; the form (varname vartype) and `vartype' is a class, then | |
1269 | ;; that class will be the type symbol. If not, then it will fall | |
1270 | ;; under the type `primary' which is a non-specific calling of the | |
1271 | ;; function. | |
1272 | (if argclass | |
1273 | (if (not (class-p argclass)) | |
1274 | (error "Unknown class type %s in method parameters" | |
1275 | argclass)) | |
1276 | ;; Generics are higher. | |
1277 | (setq key (eieio-specialized-key-to-generic-key key))) | |
1278 | ;; Put this lambda into the symbol so we can find it. | |
1279 | (eieiomt-add method code key argclass) | |
1280 | ) | |
1281 | ||
1282 | (when eieio-optimize-primary-methods-flag | |
1283 | ;; Optimizing step: | |
1284 | ;; | |
1285 | ;; If this method, after this setup, only has primary methods, then | |
1286 | ;; we can setup the generic that way. | |
1287 | (if (generic-primary-only-p method) | |
1288 | ;; If there is only one primary method, then we can go one more | |
1289 | ;; optimization step. | |
1290 | (if (generic-primary-only-one-p method) | |
1291 | (eieio-defgeneric-reset-generic-form-primary-only-one method) | |
1292 | (eieio-defgeneric-reset-generic-form-primary-only method)) | |
1293 | (eieio-defgeneric-reset-generic-form method))) | |
1294 | ||
1295 | method) | |
1296 | ||
1297 | ;;; Slot type validation | |
1298 | ||
1299 | ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid | |
1300 | ;; requiring the CL library at run-time. It can be eliminated if/when | |
1301 | ;; `typep' is merged into Emacs core. | |
1302 | (defun eieio--typep (val type) | |
1303 | (if (symbolp type) | |
1304 | (cond ((get type 'cl-deftype-handler) | |
1305 | (eieio--typep val (funcall (get type 'cl-deftype-handler)))) | |
1306 | ((eq type t) t) | |
1307 | ((eq type 'null) (null val)) | |
1308 | ((eq type 'atom) (atom val)) | |
1309 | ((eq type 'float) (and (numberp val) (not (integerp val)))) | |
1310 | ((eq type 'real) (numberp val)) | |
1311 | ((eq type 'fixnum) (integerp val)) | |
1312 | ((memq type '(character string-char)) (characterp val)) | |
1313 | (t | |
1314 | (let* ((name (symbol-name type)) | |
1315 | (namep (intern (concat name "p")))) | |
1316 | (if (fboundp namep) | |
1317 | (funcall `(lambda () (,namep val))) | |
1318 | (funcall `(lambda () | |
1319 | (,(intern (concat name "-p")) val))))))) | |
1320 | (cond ((get (car type) 'cl-deftype-handler) | |
1321 | (eieio--typep val (apply (get (car type) 'cl-deftype-handler) | |
1322 | (cdr type)))) | |
1323 | ((memq (car type) '(integer float real number)) | |
1324 | (and (eieio--typep val (car type)) | |
1325 | (or (memq (cadr type) '(* nil)) | |
1326 | (if (consp (cadr type)) | |
1327 | (> val (car (cadr type))) | |
1328 | (>= val (cadr type)))) | |
1329 | (or (memq (caddr type) '(* nil)) | |
1330 | (if (consp (car (cddr type))) | |
1331 | (< val (caar (cddr type))) | |
1332 | (<= val (car (cddr type))))))) | |
1333 | ((memq (car type) '(and or not)) | |
1334 | (eval (cons (car type) | |
1335 | (mapcar (lambda (x) | |
1336 | `(eieio--typep (quote ,val) (quote ,x))) | |
1337 | (cdr type))))) | |
1338 | ((memq (car type) '(member member*)) | |
1339 | (memql val (cdr type))) | |
1340 | ((eq (car type) 'satisfies) | |
1341 | (funcall `(lambda () (,(cadr type) val)))) | |
1342 | (t (error "Bad type spec: %s" type))))) | |
1343 | ||
1344 | (defun eieio-perform-slot-validation (spec value) | |
1345 | "Return non-nil if SPEC does not match VALUE." | |
1346 | (or (eq spec t) ; t always passes | |
1347 | (eq value eieio-unbound) ; unbound always passes | |
1348 | (eieio--typep value spec))) | |
1349 | ||
1350 | (defun eieio-validate-slot-value (class slot-idx value slot) | |
1351 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. | |
1352 | Checks the :type specifier. | |
1353 | SLOT is the slot that is being checked, and is only used when throwing | |
1354 | an error." | |
1355 | (if eieio-skip-typecheck | |
1356 | nil | |
1357 | ;; Trim off object IDX junk added in for the object index. | |
1358 | (setq slot-idx (- slot-idx 3)) | |
1359 | (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) | |
1360 | (if (not (eieio-perform-slot-validation st value)) | |
1361 | (signal 'invalid-slot-type (list class slot st value)))))) | |
1362 | ||
1363 | (defun eieio-validate-class-slot-value (class slot-idx value slot) | |
1364 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. | |
1365 | Checks the :type specifier. | |
1366 | SLOT is the slot that is being checked, and is only used when throwing | |
1367 | an error." | |
1368 | (if eieio-skip-typecheck | |
1369 | nil | |
1370 | (let ((st (aref (eieio--class-class-allocation-type (class-v class)) | |
1371 | slot-idx))) | |
1372 | (if (not (eieio-perform-slot-validation st value)) | |
1373 | (signal 'invalid-slot-type (list class slot st value)))))) | |
1374 | ||
1375 | (defun eieio-barf-if-slot-unbound (value instance slotname fn) | |
1376 | "Throw a signal if VALUE is a representation of an UNBOUND slot. | |
1377 | INSTANCE is the object being referenced. SLOTNAME is the offending | |
1378 | slot. If the slot is ok, return VALUE. | |
1379 | Argument FN is the function calling this verifier." | |
1380 | (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) | |
1381 | (slot-unbound instance (eieio--object-class instance) slotname fn) | |
1382 | value)) | |
1383 | ||
1384 | \f | |
1385 | ;;; Get/Set slots in an object. | |
1386 | ;; | |
1387 | (defun eieio-oref (obj slot) | |
1388 | "Return the value in OBJ at SLOT in the object vector." | |
1389 | (eieio--check-type (or eieio-object-p class-p) obj) | |
1390 | (eieio--check-type symbolp slot) | |
1391 | (if (class-p obj) (eieio-class-un-autoload obj)) | |
1392 | (let* ((class (if (class-p obj) obj (eieio--object-class obj))) | |
1393 | (c (eieio-slot-name-index class obj slot))) | |
1394 | (if (not c) | |
1395 | ;; It might be missing because it is a :class allocated slot. | |
1396 | ;; Let's check that info out. | |
1397 | (if (setq c (eieio-class-slot-name-index class slot)) | |
1398 | ;; Oref that slot. | |
1399 | (aref (eieio--class-class-allocation-values (class-v class)) c) | |
1400 | ;; The slot-missing method is a cool way of allowing an object author | |
1401 | ;; to intercept missing slot definitions. Since it is also the LAST | |
1402 | ;; thing called in this fn, its return value would be retrieved. | |
1403 | (slot-missing obj slot 'oref) | |
1404 | ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) | |
1405 | ) | |
1406 | (eieio--check-type eieio-object-p obj) | |
1407 | (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) | |
1408 | ||
1409 | ||
1410 | (defun eieio-oref-default (obj slot) | |
1411 | "Do the work for the macro `oref-default' with similar parameters. | |
1412 | Fills in OBJ's SLOT with its default value." | |
1413 | (eieio--check-type (or eieio-object-p class-p) obj) | |
1414 | (eieio--check-type symbolp slot) | |
1415 | (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) | |
1416 | (c (eieio-slot-name-index cl obj slot))) | |
1417 | (if (not c) | |
1418 | ;; It might be missing because it is a :class allocated slot. | |
1419 | ;; Let's check that info out. | |
1420 | (if (setq c | |
1421 | (eieio-class-slot-name-index cl slot)) | |
1422 | ;; Oref that slot. | |
1423 | (aref (eieio--class-class-allocation-values (class-v cl)) | |
1424 | c) | |
1425 | (slot-missing obj slot 'oref-default) | |
1426 | ;;(signal 'invalid-slot-name (list (class-name cl) slot)) | |
1427 | ) | |
1428 | (eieio-barf-if-slot-unbound | |
1429 | (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) | |
1430 | (eieio-default-eval-maybe val)) | |
1431 | obj cl 'oref-default)))) | |
1432 | ||
1433 | (defun eieio-default-eval-maybe (val) | |
1434 | "Check VAL, and return what `oref-default' would provide." | |
1435 | (cond | |
1436 | ;; Is it a function call? If so, evaluate it. | |
1437 | ((eieio-eval-default-p val) | |
1438 | (eval val)) | |
1439 | ;;;; check for quoted things, and unquote them | |
1440 | ;;((and (consp val) (eq (car val) 'quote)) | |
1441 | ;; (car (cdr val))) | |
1442 | ;; return it verbatim | |
1443 | (t val))) | |
1444 | ||
1445 | (defun eieio-oset (obj slot value) | |
1446 | "Do the work for the macro `oset'. | |
1447 | Fills in OBJ's SLOT with VALUE." | |
1448 | (eieio--check-type eieio-object-p obj) | |
1449 | (eieio--check-type symbolp slot) | |
1450 | (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) | |
1451 | (if (not c) | |
1452 | ;; It might be missing because it is a :class allocated slot. | |
1453 | ;; Let's check that info out. | |
1454 | (if (setq c | |
1455 | (eieio-class-slot-name-index (eieio--object-class obj) slot)) | |
1456 | ;; Oset that slot. | |
1457 | (progn | |
1458 | (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) | |
1459 | (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) | |
1460 | c value)) | |
1461 | ;; See oref for comment on `slot-missing' | |
1462 | (slot-missing obj slot 'oset value) | |
1463 | ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) | |
1464 | ) | |
1465 | (eieio-validate-slot-value (eieio--object-class obj) c value slot) | |
1466 | (aset obj c value)))) | |
1467 | ||
1468 | (defun eieio-oset-default (class slot value) | |
1469 | "Do the work for the macro `oset-default'. | |
1470 | Fills in the default value in CLASS' in SLOT with VALUE." | |
1471 | (eieio--check-type class-p class) | |
1472 | (eieio--check-type symbolp slot) | |
1473 | (eieio--with-scoped-class class | |
1474 | (let* ((c (eieio-slot-name-index class nil slot))) | |
1475 | (if (not c) | |
1476 | ;; It might be missing because it is a :class allocated slot. | |
1477 | ;; Let's check that info out. | |
1478 | (if (setq c (eieio-class-slot-name-index class slot)) | |
1479 | (progn | |
1480 | ;; Oref that slot. | |
1481 | (eieio-validate-class-slot-value class c value slot) | |
1482 | (aset (eieio--class-class-allocation-values (class-v class)) c | |
1483 | value)) | |
1484 | (signal 'invalid-slot-name (list (eieio-class-name class) slot))) | |
1485 | (eieio-validate-slot-value class c value slot) | |
1486 | ;; Set this into the storage for defaults. | |
1487 | (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) | |
1488 | value) | |
1489 | ;; Take the value, and put it into our cache object. | |
1490 | (eieio-oset (eieio--class-default-object-cache (class-v class)) | |
1491 | slot value) | |
1492 | )))) | |
1493 | ||
1494 | \f | |
1495 | ;;; EIEIO internal search functions | |
1496 | ;; | |
1497 | (defun eieio-slot-originating-class-p (start-class slot) | |
1498 | "Return non-nil if START-CLASS is the first class to define SLOT. | |
1499 | This is for testing if the class currently in scope is the class that defines SLOT | |
1500 | so that we can protect private slots." | |
1501 | (let ((par (eieio-class-parents-fast start-class)) | |
1502 | (ret t)) | |
1503 | (if (not par) | |
1504 | t | |
1505 | (while (and par ret) | |
1506 | (if (intern-soft (symbol-name slot) | |
1507 | (eieio--class-symbol-obarray (class-v (car par)))) | |
1508 | (setq ret nil)) | |
1509 | (setq par (cdr par))) | |
1510 | ret))) | |
1511 | ||
1512 | (defun eieio-slot-name-index (class obj slot) | |
1513 | "In CLASS for OBJ find the index of the named SLOT. | |
1514 | The slot is a symbol which is installed in CLASS by the `defclass' | |
1515 | call. OBJ can be nil, but if it is an object, and the slot in question | |
1516 | is protected, access will be allowed if OBJ is a child of the currently | |
1517 | scoped class. | |
1518 | If SLOT is the value created with :initarg instead, | |
1519 | reverse-lookup that name, and recurse with the associated slot value." | |
1520 | ;; Removed checks to outside this call | |
1521 | (let* ((fsym (intern-soft (symbol-name slot) | |
1522 | (eieio--class-symbol-obarray (class-v class)))) | |
1523 | (fsi (if (symbolp fsym) (symbol-value fsym) nil))) | |
1524 | (if (integerp fsi) | |
1525 | (cond | |
1526 | ((not (get fsym 'protection)) | |
1527 | (+ 3 fsi)) | |
1528 | ((and (eq (get fsym 'protection) 'protected) | |
1529 | (eieio--scoped-class) | |
1530 | (or (child-of-class-p class (eieio--scoped-class)) | |
1531 | (and (eieio-object-p obj) | |
1532 | (child-of-class-p class (eieio--object-class obj))))) | |
1533 | (+ 3 fsi)) | |
1534 | ((and (eq (get fsym 'protection) 'private) | |
1535 | (or (and (eieio--scoped-class) | |
1536 | (eieio-slot-originating-class-p (eieio--scoped-class) slot)) | |
1537 | eieio-initializing-object)) | |
1538 | (+ 3 fsi)) | |
1539 | (t nil)) | |
1540 | (let ((fn (eieio-initarg-to-attribute class slot))) | |
1541 | (if fn (eieio-slot-name-index class obj fn) nil))))) | |
1542 | ||
1543 | (defun eieio-class-slot-name-index (class slot) | |
1544 | "In CLASS find the index of the named SLOT. | |
1545 | The slot is a symbol which is installed in CLASS by the `defclass' | |
1546 | call. If SLOT is the value created with :initarg instead, | |
1547 | reverse-lookup that name, and recurse with the associated slot value." | |
1548 | ;; This will happen less often, and with fewer slots. Do this the | |
1549 | ;; storage cheap way. | |
1550 | (let* ((a (eieio--class-class-allocation-a (class-v class))) | |
1551 | (l1 (length a)) | |
1552 | (af (memq slot a)) | |
1553 | (l2 (length af))) | |
1554 | ;; Slot # is length of the total list, minus the remaining list of | |
1555 | ;; the found slot. | |
1556 | (if af (- l1 l2)))) | |
1557 | ||
1558 | ;;; | |
1559 | ;; Way to assign slots based on a list. Used for constructors, or | |
1560 | ;; even resetting an object at run-time | |
1561 | ;; | |
1562 | (defun eieio-set-defaults (obj &optional set-all) | |
1563 | "Take object OBJ, and reset all slots to their defaults. | |
1564 | If SET-ALL is non-nil, then when a default is nil, that value is | |
1565 | reset. If SET-ALL is nil, the slots are only reset if the default is | |
1566 | not nil." | |
1567 | (eieio--with-scoped-class (eieio--object-class obj) | |
1568 | (let ((eieio-initializing-object t) | |
1569 | (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) | |
1570 | (while pub | |
1571 | (let ((df (eieio-oref-default obj (car pub)))) | |
1572 | (if (or df set-all) | |
1573 | (eieio-oset obj (car pub) df))) | |
1574 | (setq pub (cdr pub)))))) | |
1575 | ||
1576 | (defun eieio-initarg-to-attribute (class initarg) | |
1577 | "For CLASS, convert INITARG to the actual attribute name. | |
1578 | If there is no translation, pass it in directly (so we can cheat if | |
1579 | need be... May remove that later...)" | |
1580 | (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) | |
1581 | (if tuple | |
1582 | (cdr tuple) | |
1583 | nil))) | |
1584 | ||
1585 | (defun eieio-attribute-to-initarg (class attribute) | |
1586 | "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. | |
1587 | This is usually a symbol that starts with `:'." | |
1588 | (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class))))) | |
1589 | (if tuple | |
1590 | (car tuple) | |
1591 | nil))) | |
1592 | ||
1593 | ;;; | |
1594 | ;; Method Invocation order: C3 | |
1595 | (defun eieio-c3-candidate (class remaining-inputs) | |
1596 | "Return CLASS if it can go in the result now, otherwise nil" | |
1597 | ;; Ensure CLASS is not in any position but the first in any of the | |
1598 | ;; element lists of REMAINING-INPUTS. | |
1599 | (and (not (let ((found nil)) | |
1600 | (while (and remaining-inputs (not found)) | |
1601 | (setq found (member class (cdr (car remaining-inputs))) | |
1602 | remaining-inputs (cdr remaining-inputs))) | |
1603 | found)) | |
1604 | class)) | |
1605 | ||
1606 | (defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) | |
1607 | "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. | |
1608 | If a consistent order does not exist, signal an error." | |
1609 | (if (let ((tail remaining-inputs) | |
1610 | (found nil)) | |
1611 | (while (and tail (not found)) | |
1612 | (setq found (car tail) tail (cdr tail))) | |
1613 | (not found)) | |
1614 | ;; If all remaining inputs are empty lists, we are done. | |
1615 | (nreverse reversed-partial-result) | |
1616 | ;; Otherwise, we try to find the next element of the result. This | |
1617 | ;; is achieved by considering the first element of each | |
1618 | ;; (non-empty) input list and accepting a candidate if it is | |
1619 | ;; consistent with the rests of the input lists. | |
1620 | (let* ((found nil) | |
1621 | (tail remaining-inputs) | |
1622 | (next (progn | |
1623 | (while (and tail (not found)) | |
1624 | (setq found (and (car tail) | |
1625 | (eieio-c3-candidate (caar tail) | |
1626 | remaining-inputs)) | |
1627 | tail (cdr tail))) | |
1628 | found))) | |
1629 | (if next | |
1630 | ;; The graph is consistent so far, add NEXT to result and | |
1631 | ;; merge input lists, dropping NEXT from their heads where | |
1632 | ;; applicable. | |
1633 | (eieio-c3-merge-lists | |
1634 | (cons next reversed-partial-result) | |
1635 | (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) | |
1636 | remaining-inputs)) | |
1637 | ;; The graph is inconsistent, give up | |
1638 | (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) | |
1639 | ||
1640 | (defun eieio-class-precedence-c3 (class) | |
1641 | "Return all parents of CLASS in c3 order." | |
1642 | (let ((parents (eieio-class-parents-fast class))) | |
1643 | (eieio-c3-merge-lists | |
1644 | (list class) | |
1645 | (append | |
1646 | (or | |
1647 | (mapcar | |
1648 | (lambda (x) | |
1649 | (eieio-class-precedence-c3 x)) | |
1650 | parents) | |
1651 | '((eieio-default-superclass))) | |
1652 | (list parents)))) | |
1653 | ) | |
1654 | ;;; | |
1655 | ;; Method Invocation Order: Depth First | |
1656 | ||
1657 | (defun eieio-class-precedence-dfs (class) | |
1658 | "Return all parents of CLASS in depth-first order." | |
1659 | (let* ((parents (eieio-class-parents-fast class)) | |
1660 | (classes (copy-sequence | |
1661 | (apply #'append | |
1662 | (list class) | |
1663 | (or | |
1664 | (mapcar | |
1665 | (lambda (parent) | |
1666 | (cons parent | |
1667 | (eieio-class-precedence-dfs parent))) | |
1668 | parents) | |
1669 | '((eieio-default-superclass)))))) | |
1670 | (tail classes)) | |
1671 | ;; Remove duplicates. | |
1672 | (while tail | |
1673 | (setcdr tail (delq (car tail) (cdr tail))) | |
1674 | (setq tail (cdr tail))) | |
1675 | classes)) | |
1676 | ||
1677 | ;;; | |
1678 | ;; Method Invocation Order: Breadth First | |
1679 | (defun eieio-class-precedence-bfs (class) | |
1680 | "Return all parents of CLASS in breadth-first order." | |
1681 | (let ((result) | |
1682 | (queue (or (eieio-class-parents-fast class) | |
1683 | '(eieio-default-superclass)))) | |
1684 | (while queue | |
1685 | (let ((head (pop queue))) | |
1686 | (unless (member head result) | |
1687 | (push head result) | |
1688 | (unless (eq head 'eieio-default-superclass) | |
1689 | (setq queue (append queue (or (eieio-class-parents-fast head) | |
1690 | '(eieio-default-superclass)))))))) | |
1691 | (cons class (nreverse result))) | |
1692 | ) | |
1693 | ||
1694 | ;;; | |
1695 | ;; Method Invocation Order | |
1696 | ||
1697 | (defun eieio-class-precedence-list (class) | |
1698 | "Return (transitively closed) list of parents of CLASS. | |
1699 | The order, in which the parents are returned depends on the | |
1700 | method invocation orders of the involved classes." | |
1701 | (if (or (null class) (eq class 'eieio-default-superclass)) | |
1702 | nil | |
1703 | (case (class-method-invocation-order class) | |
1704 | (:depth-first | |
1705 | (eieio-class-precedence-dfs class)) | |
1706 | (:breadth-first | |
1707 | (eieio-class-precedence-bfs class)) | |
1708 | (:c3 | |
1709 | (eieio-class-precedence-c3 class)))) | |
1710 | ) | |
1711 | (define-obsolete-function-alias | |
1712 | 'class-precedence-list 'eieio-class-precedence-list "24.4") | |
1713 | ||
1714 | \f | |
1715 | ;;; CLOS generics internal function handling | |
1716 | ;; | |
1717 | (defvar eieio-generic-call-methodname nil | |
1718 | "When using `call-next-method', provides a context on how to do it.") | |
1719 | (defvar eieio-generic-call-arglst nil | |
1720 | "When using `call-next-method', provides a context for parameters.") | |
1721 | (defvar eieio-generic-call-key nil | |
1722 | "When using `call-next-method', provides a context for the current key. | |
1723 | Keys are a number representing :before, :primary, and :after methods.") | |
1724 | (defvar eieio-generic-call-next-method-list nil | |
1725 | "When executing a PRIMARY or STATIC method, track the 'next-method'. | |
1726 | During executions, the list is first generated, then as each next method | |
1727 | is called, the next method is popped off the stack.") | |
1728 | ||
1729 | (define-obsolete-variable-alias 'eieio-pre-method-execution-hooks | |
1730 | 'eieio-pre-method-execution-functions "24.3") | |
1731 | (defvar eieio-pre-method-execution-functions nil | |
1732 | "Abnormal hook run just before an EIEIO method is executed. | |
1733 | The hook function must accept one argument, the list of forms | |
1734 | about to be executed.") | |
1735 | ||
1736 | (defun eieio-generic-call (method args) | |
1737 | "Call METHOD with ARGS. | |
1738 | ARGS provides the context on which implementation to use. | |
1739 | This should only be called from a generic function." | |
1740 | ;; We must expand our arguments first as they are always | |
1741 | ;; passed in as quoted symbols | |
1742 | (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) | |
1743 | (eieio-generic-call-methodname method) | |
1744 | (eieio-generic-call-arglst args) | |
1745 | (firstarg nil) | |
1746 | (primarymethodlist nil)) | |
1747 | ;; get a copy | |
1748 | (setq newargs args | |
1749 | firstarg (car newargs)) | |
1750 | ;; Is the class passed in autoloaded? | |
1751 | ;; Since class names are also constructors, they can be autoloaded | |
1752 | ;; via the autoload command. Check for this, and load them in. | |
1753 | ;; It is ok if it doesn't turn out to be a class. Probably want that | |
1754 | ;; function loaded anyway. | |
1755 | (if (and (symbolp firstarg) | |
1756 | (fboundp firstarg) | |
1757 | (listp (symbol-function firstarg)) | |
1758 | (eq 'autoload (car (symbol-function firstarg)))) | |
1759 | (load (nth 1 (symbol-function firstarg)))) | |
1760 | ;; Determine the class to use. | |
1761 | (cond ((eieio-object-p firstarg) | |
1762 | (setq mclass (eieio--object-class firstarg))) | |
1763 | ((class-p firstarg) | |
1764 | (setq mclass firstarg)) | |
1765 | ) | |
1766 | ;; Make sure the class is a valid class | |
1767 | ;; mclass can be nil (meaning a generic for should be used. | |
1768 | ;; mclass cannot have a value that is not a class, however. | |
1769 | (when (and (not (null mclass)) (not (class-p mclass))) | |
1770 | (error "Cannot dispatch method %S on class %S" | |
1771 | method mclass) | |
1772 | ) | |
1773 | ;; Now create a list in reverse order of all the calls we have | |
1774 | ;; make in order to successfully do this right. Rules: | |
1775 | ;; 1) Only call generics if scoped-class is not defined | |
1776 | ;; This prevents multiple calls in the case of recursion | |
1777 | ;; 2) Only call static if this is a static method. | |
1778 | ;; 3) Only call specifics if the definition allows for them. | |
1779 | ;; 4) Call in order based on :before, :primary, and :after | |
1780 | (when (eieio-object-p firstarg) | |
1781 | ;; Non-static calls do all this stuff. | |
1782 | ||
1783 | ;; :after methods | |
1784 | (setq tlambdas | |
1785 | (if mclass | |
1786 | (eieiomt-method-list method method-after mclass) | |
1787 | (list (eieio-generic-form method method-after nil))) | |
1788 | ;;(or (and mclass (eieio-generic-form method method-after mclass)) | |
1789 | ;; (eieio-generic-form method method-after nil)) | |
1790 | ) | |
1791 | (setq lambdas (append tlambdas lambdas) | |
1792 | keys (append (make-list (length tlambdas) method-after) keys)) | |
1793 | ||
1794 | ;; :primary methods | |
1795 | (setq tlambdas | |
1796 | (or (and mclass (eieio-generic-form method method-primary mclass)) | |
1797 | (eieio-generic-form method method-primary nil))) | |
1798 | (when tlambdas | |
1799 | (setq lambdas (cons tlambdas lambdas) | |
1800 | keys (cons method-primary keys) | |
1801 | primarymethodlist | |
1802 | (eieiomt-method-list method method-primary mclass))) | |
1803 | ||
1804 | ;; :before methods | |
1805 | (setq tlambdas | |
1806 | (if mclass | |
1807 | (eieiomt-method-list method method-before mclass) | |
1808 | (list (eieio-generic-form method method-before nil))) | |
1809 | ;;(or (and mclass (eieio-generic-form method method-before mclass)) | |
1810 | ;; (eieio-generic-form method method-before nil)) | |
1811 | ) | |
1812 | (setq lambdas (append tlambdas lambdas) | |
1813 | keys (append (make-list (length tlambdas) method-before) keys)) | |
1814 | ) | |
1815 | ||
1816 | (if mclass | |
1817 | ;; For the case of a class, | |
1818 | ;; if there were no methods found, then there could be :static methods. | |
1819 | (when (not lambdas) | |
1820 | (setq tlambdas | |
1821 | (eieio-generic-form method method-static mclass)) | |
1822 | (setq lambdas (cons tlambdas lambdas) | |
1823 | keys (cons method-static keys) | |
1824 | primarymethodlist ;; Re-use even with bad name here | |
1825 | (eieiomt-method-list method method-static mclass))) | |
1826 | ;; For the case of no class (ie - mclass == nil) then there may | |
1827 | ;; be a primary method. | |
1828 | (setq tlambdas | |
1829 | (eieio-generic-form method method-primary nil)) | |
1830 | (when tlambdas | |
1831 | (setq lambdas (cons tlambdas lambdas) | |
1832 | keys (cons method-primary keys) | |
1833 | primarymethodlist | |
1834 | (eieiomt-method-list method method-primary nil))) | |
1835 | ) | |
1836 | ||
1837 | (run-hook-with-args 'eieio-pre-method-execution-functions | |
1838 | primarymethodlist) | |
1839 | ||
1840 | ;; Now loop through all occurrences forms which we must execute | |
1841 | ;; (which are happily sorted now) and execute them all! | |
1842 | (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) | |
1843 | (while lambdas | |
1844 | (if (car lambdas) | |
1845 | (eieio--with-scoped-class (cdr (car lambdas)) | |
1846 | (let* ((eieio-generic-call-key (car keys)) | |
1847 | (has-return-val | |
1848 | (or (= eieio-generic-call-key method-primary) | |
1849 | (= eieio-generic-call-key method-static))) | |
1850 | (eieio-generic-call-next-method-list | |
1851 | ;; Use the cdr, as the first element is the fcn | |
1852 | ;; we are calling right now. | |
1853 | (when has-return-val (cdr primarymethodlist))) | |
1854 | ) | |
1855 | (setq found t) | |
1856 | ;;(setq rval (apply (car (car lambdas)) newargs)) | |
1857 | (setq lastval (apply (car (car lambdas)) newargs)) | |
1858 | (when has-return-val | |
1859 | (setq rval lastval | |
1860 | rvalever t)) | |
1861 | ))) | |
1862 | (setq lambdas (cdr lambdas) | |
1863 | keys (cdr keys))) | |
1864 | (if (not found) | |
1865 | (if (eieio-object-p (car args)) | |
1866 | (setq rval (apply 'no-applicable-method (car args) method args) | |
1867 | rvalever t) | |
1868 | (signal | |
1869 | 'no-method-definition | |
1870 | (list method args)))) | |
1871 | ;; Right Here... it could be that lastval is returned when | |
1872 | ;; rvalever is nil. Is that right? | |
1873 | rval))) | |
1874 | ||
1875 | (defun eieio-generic-call-primary-only (method args) | |
1876 | "Call METHOD with ARGS for methods with only :PRIMARY implementations. | |
1877 | ARGS provides the context on which implementation to use. | |
1878 | This should only be called from a generic function. | |
1879 | ||
1880 | This method is like `eieio-generic-call', but only | |
1881 | implementations in the :PRIMARY slot are queried. After many | |
1882 | years of use, it appears that over 90% of methods in use | |
1883 | have :PRIMARY implementations only. We can therefore optimize | |
1884 | for this common case to improve performance." | |
1885 | ;; We must expand our arguments first as they are always | |
1886 | ;; passed in as quoted symbols | |
1887 | (let ((newargs nil) (mclass nil) (lambdas nil) | |
1888 | (eieio-generic-call-methodname method) | |
1889 | (eieio-generic-call-arglst args) | |
1890 | (firstarg nil) | |
1891 | (primarymethodlist nil) | |
1892 | ) | |
1893 | ;; get a copy | |
1894 | (setq newargs args | |
1895 | firstarg (car newargs)) | |
1896 | ||
1897 | ;; Determine the class to use. | |
1898 | (cond ((eieio-object-p firstarg) | |
1899 | (setq mclass (eieio--object-class firstarg))) | |
1900 | ((not firstarg) | |
1901 | (error "Method %s called on nil" method)) | |
1902 | ((not (eieio-object-p firstarg)) | |
1903 | (error "Primary-only method %s called on something not an object" method)) | |
1904 | (t | |
1905 | (error "EIEIO Error: Improperly classified method %s as primary only" | |
1906 | method) | |
1907 | )) | |
1908 | ;; Make sure the class is a valid class | |
1909 | ;; mclass can be nil (meaning a generic for should be used. | |
1910 | ;; mclass cannot have a value that is not a class, however. | |
1911 | (when (null mclass) | |
1912 | (error "Cannot dispatch method %S on class %S" method mclass) | |
1913 | ) | |
1914 | ||
1915 | ;; :primary methods | |
1916 | (setq lambdas (eieio-generic-form method method-primary mclass)) | |
1917 | (setq primarymethodlist ;; Re-use even with bad name here | |
1918 | (eieiomt-method-list method method-primary mclass)) | |
1919 | ||
1920 | ;; Now loop through all occurrences forms which we must execute | |
1921 | ;; (which are happily sorted now) and execute them all! | |
1922 | (eieio--with-scoped-class (cdr lambdas) | |
1923 | (let* ((rval nil) (lastval nil) (rvalever nil) | |
1924 | (eieio-generic-call-key method-primary) | |
1925 | ;; Use the cdr, as the first element is the fcn | |
1926 | ;; we are calling right now. | |
1927 | (eieio-generic-call-next-method-list (cdr primarymethodlist)) | |
1928 | ) | |
1929 | ||
1930 | (if (or (not lambdas) (not (car lambdas))) | |
1931 | ||
1932 | ;; No methods found for this impl... | |
1933 | (if (eieio-object-p (car args)) | |
1934 | (setq rval (apply 'no-applicable-method (car args) method args) | |
1935 | rvalever t) | |
1936 | (signal | |
1937 | 'no-method-definition | |
1938 | (list method args))) | |
1939 | ||
1940 | ;; Do the regular implementation here. | |
1941 | ||
1942 | (run-hook-with-args 'eieio-pre-method-execution-functions | |
1943 | lambdas) | |
1944 | ||
1945 | (setq lastval (apply (car lambdas) newargs)) | |
1946 | (setq rval lastval | |
1947 | rvalever t) | |
1948 | ) | |
1949 | ||
1950 | ;; Right Here... it could be that lastval is returned when | |
1951 | ;; rvalever is nil. Is that right? | |
1952 | rval)))) | |
1953 | ||
1954 | (defun eieiomt-method-list (method key class) | |
1955 | "Return an alist list of methods lambdas. | |
1956 | METHOD is the method name. | |
1957 | KEY represents either :before, or :after methods. | |
1958 | CLASS is the starting class to search from in the method tree. | |
1959 | If CLASS is nil, then an empty list of methods should be returned." | |
1960 | ;; Note: eieiomt - the MT means MethodTree. See more comments below | |
1961 | ;; for the rest of the eieiomt methods. | |
1962 | ||
1963 | ;; Collect lambda expressions stored for the class and its parent | |
1964 | ;; classes. | |
1965 | (let (lambdas) | |
1966 | (dolist (ancestor (eieio-class-precedence-list class)) | |
1967 | ;; Lookup the form to use for the PRIMARY object for the next level | |
1968 | (let ((tmpl (eieio-generic-form method key ancestor))) | |
1969 | (when (and tmpl | |
1970 | (or (not lambdas) | |
1971 | ;; This prevents duplicates coming out of the | |
1972 | ;; class method optimizer. Perhaps we should | |
1973 | ;; just not optimize before/afters? | |
1974 | (not (member tmpl lambdas)))) | |
1975 | (push tmpl lambdas)))) | |
1976 | ||
1977 | ;; Return collected lambda. For :after methods, return in current | |
1978 | ;; order (most general class last); Otherwise, reverse order. | |
1979 | (if (eq key method-after) | |
1980 | lambdas | |
1981 | (nreverse lambdas)))) | |
1982 | ||
1983 | \f | |
1984 | ;;; | |
1985 | ;; eieio-method-tree : eieiomt- | |
1986 | ;; | |
1987 | ;; Stored as eieio-method-tree in property list of a generic method | |
1988 | ;; | |
1989 | ;; (eieio-method-tree . [BEFORE PRIMARY AFTER | |
1990 | ;; genericBEFORE genericPRIMARY genericAFTER]) | |
1991 | ;; and | |
1992 | ;; (eieio-method-obarray . [BEFORE PRIMARY AFTER | |
1993 | ;; genericBEFORE genericPRIMARY genericAFTER]) | |
1994 | ;; where the association is a vector. | |
1995 | ;; (aref 0 -- all static methods. | |
1996 | ;; (aref 1 -- all methods classified as :before | |
1997 | ;; (aref 2 -- all methods classified as :primary | |
1998 | ;; (aref 3 -- all methods classified as :after | |
1999 | ;; (aref 4 -- a generic classified as :before | |
2000 | ;; (aref 5 -- a generic classified as :primary | |
2001 | ;; (aref 6 -- a generic classified as :after | |
2002 | ;; | |
2003 | (defvar eieiomt-optimizing-obarray nil | |
2004 | "While mapping atoms, this contain the obarray being optimized.") | |
2005 | ||
2006 | (defun eieiomt-install (method-name) | |
2007 | "Install the method tree, and obarray onto METHOD-NAME. | |
2008 | Do not do the work if they already exist." | |
2009 | (let ((emtv (get method-name 'eieio-method-tree)) | |
2010 | (emto (get method-name 'eieio-method-obarray))) | |
2011 | (if (or (not emtv) (not emto)) | |
2012 | (progn | |
2013 | (setq emtv (put method-name 'eieio-method-tree | |
2014 | (make-vector method-num-slots nil)) | |
2015 | emto (put method-name 'eieio-method-obarray | |
2016 | (make-vector method-num-slots nil))) | |
2017 | (aset emto 0 (make-vector 11 0)) | |
2018 | (aset emto 1 (make-vector 11 0)) | |
2019 | (aset emto 2 (make-vector 41 0)) | |
2020 | (aset emto 3 (make-vector 11 0)) | |
2021 | )))) | |
2022 | ||
2023 | (defun eieiomt-add (method-name method key class) | |
2024 | "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. | |
2025 | METHOD-NAME is the name created by a call to `defgeneric'. | |
2026 | METHOD are the forms for a given implementation. | |
2027 | KEY is an integer (see comment in eieio.el near this function) which | |
2028 | is associated with the :static :before :primary and :after tags. | |
2029 | It also indicates if CLASS is defined or not. | |
2030 | CLASS is the class this method is associated with." | |
2031 | (if (or (> key method-num-slots) (< key 0)) | |
2032 | (error "eieiomt-add: method key error!")) | |
2033 | (let ((emtv (get method-name 'eieio-method-tree)) | |
2034 | (emto (get method-name 'eieio-method-obarray))) | |
2035 | ;; Make sure the method tables are available. | |
2036 | (if (or (not emtv) (not emto)) | |
2037 | (error "Programmer error: eieiomt-add")) | |
2038 | ;; only add new cells on if it doesn't already exist! | |
2039 | (if (assq class (aref emtv key)) | |
2040 | (setcdr (assq class (aref emtv key)) method) | |
2041 | (aset emtv key (cons (cons class method) (aref emtv key)))) | |
2042 | ;; Add function definition into newly created symbol, and store | |
2043 | ;; said symbol in the correct obarray, otherwise use the | |
2044 | ;; other array to keep this stuff | |
2045 | (if (< key method-num-lists) | |
2046 | (let ((nsym (intern (symbol-name class) (aref emto key)))) | |
2047 | (fset nsym method))) | |
2048 | ;; Save the defmethod file location in a symbol property. | |
2049 | (let ((fname (if load-in-progress | |
2050 | load-file-name | |
2051 | buffer-file-name)) | |
2052 | loc) | |
2053 | (when fname | |
2054 | (when (string-match "\\.elc$" fname) | |
2055 | (setq fname (substring fname 0 (1- (length fname))))) | |
2056 | (setq loc (get method-name 'method-locations)) | |
2057 | (pushnew (list class fname) loc :test 'equal) | |
2058 | (put method-name 'method-locations loc))) | |
2059 | ;; Now optimize the entire obarray | |
2060 | (if (< key method-num-lists) | |
2061 | (let ((eieiomt-optimizing-obarray (aref emto key))) | |
2062 | ;; @todo - Is this overkill? Should we just clear the symbol? | |
2063 | (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) | |
2064 | )) | |
2065 | ||
2066 | (defun eieiomt-next (class) | |
2067 | "Return the next parent class for CLASS. | |
2068 | If CLASS is a superclass, return variable `eieio-default-superclass'. | |
2069 | If CLASS is variable `eieio-default-superclass' then return nil. | |
2070 | This is different from function `class-parent' as class parent returns | |
2071 | nil for superclasses. This function performs no type checking!" | |
2072 | ;; No type-checking because all calls are made from functions which | |
2073 | ;; are safe and do checking for us. | |
2074 | (or (eieio-class-parents-fast class) | |
2075 | (if (eq class 'eieio-default-superclass) | |
2076 | nil | |
2077 | '(eieio-default-superclass)))) | |
2078 | ||
2079 | (defun eieiomt-sym-optimize (s) | |
2080 | "Find the next class above S which has a function body for the optimizer." | |
2081 | ;; Set the value to nil in case there is no nearest cell. | |
2082 | (set s nil) | |
2083 | ;; Find the nearest cell that has a function body. If we find one, | |
2084 | ;; we replace the nil from above. | |
2085 | (let ((external-symbol (intern-soft (symbol-name s)))) | |
2086 | (catch 'done | |
2087 | (dolist (ancestor (rest (eieio-class-precedence-list external-symbol))) | |
2088 | (let ((ov (intern-soft (symbol-name ancestor) | |
2089 | eieiomt-optimizing-obarray))) | |
2090 | (when (fboundp ov) | |
2091 | (set s ov) ;; store ov as our next symbol | |
2092 | (throw 'done ancestor))))))) | |
2093 | ||
2094 | (defun eieio-generic-form (method key class) | |
2095 | "Return the lambda form belonging to METHOD using KEY based upon CLASS. | |
2096 | If CLASS is not a class then use `generic' instead. If class has | |
2097 | no form, but has a parent class, then trace to that parent class. | |
2098 | The first time a form is requested from a symbol, an optimized path | |
2099 | is memorized for faster future use." | |
2100 | (let ((emto (aref (get method 'eieio-method-obarray) | |
2101 | (if class key (eieio-specialized-key-to-generic-key key))))) | |
2102 | (if (class-p class) | |
2103 | ;; 1) find our symbol | |
2104 | (let ((cs (intern-soft (symbol-name class) emto))) | |
2105 | (if (not cs) | |
2106 | ;; 2) If there isn't one, then make one. | |
2107 | ;; This can be slow since it only occurs once | |
2108 | (progn | |
2109 | (setq cs (intern (symbol-name class) emto)) | |
2110 | ;; 2.1) Cache its nearest neighbor with a quick optimize | |
2111 | ;; which should only occur once for this call ever | |
2112 | (let ((eieiomt-optimizing-obarray emto)) | |
2113 | (eieiomt-sym-optimize cs)))) | |
2114 | ;; 3) If it's bound return this one. | |
2115 | (if (fboundp cs) | |
2116 | (cons cs (eieio--class-symbol (class-v class))) | |
2117 | ;; 4) If it's not bound then this variable knows something | |
2118 | (if (symbol-value cs) | |
2119 | (progn | |
2120 | ;; 4.1) This symbol holds the next class in its value | |
2121 | (setq class (symbol-value cs) | |
2122 | cs (intern-soft (symbol-name class) emto)) | |
2123 | ;; 4.2) The optimizer should always have chosen a | |
2124 | ;; function-symbol | |
2125 | ;;(if (fboundp cs) | |
2126 | (cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) | |
2127 | ;;(error "EIEIO optimizer: erratic data loss!")) | |
2128 | ) | |
2129 | ;; There never will be a funcall... | |
2130 | nil))) | |
2131 | ;; for a generic call, what is a list, is the function body we want. | |
2132 | (let ((emtl (aref (get method 'eieio-method-tree) | |
2133 | (if class key (eieio-specialized-key-to-generic-key key))))) | |
2134 | (if emtl | |
2135 | ;; The car of EMTL is supposed to be a class, which in this | |
2136 | ;; case is nil, so skip it. | |
2137 | (cons (cdr (car emtl)) nil) | |
2138 | nil))))) | |
2139 | ||
2140 | \f | |
2141 | ;;; Here are some special types of errors | |
2142 | ;; | |
2143 | (intern "no-method-definition") | |
2144 | (put 'no-method-definition 'error-conditions '(no-method-definition error)) | |
2145 | (put 'no-method-definition 'error-message "No method definition") | |
2146 | ||
2147 | (intern "no-next-method") | |
2148 | (put 'no-next-method 'error-conditions '(no-next-method error)) | |
2149 | (put 'no-next-method 'error-message "No next method") | |
2150 | ||
2151 | (intern "invalid-slot-name") | |
2152 | (put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) | |
2153 | (put 'invalid-slot-name 'error-message "Invalid slot name") | |
2154 | ||
2155 | (intern "invalid-slot-type") | |
2156 | (put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) | |
2157 | (put 'invalid-slot-type 'error-message "Invalid slot type") | |
2158 | ||
2159 | (intern "unbound-slot") | |
2160 | (put 'unbound-slot 'error-conditions '(unbound-slot error nil)) | |
2161 | (put 'unbound-slot 'error-message "Unbound slot") | |
2162 | ||
2163 | (intern "inconsistent-class-hierarchy") | |
2164 | (put 'inconsistent-class-hierarchy 'error-conditions | |
2165 | '(inconsistent-class-hierarchy error nil)) | |
2166 | (put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") | |
2167 | ||
2168 | ;;; Obsolete backward compatibility functions. | |
2169 | ;; Needed to run byte-code compiled with the EIEIO of Emacs-23. | |
2170 | ||
2171 | (defun eieio-defmethod (method args) | |
2172 | "Obsolete work part of an old version of the `defmethod' macro." | |
2173 | (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) | |
2174 | ;; find optional keys | |
2175 | (setq key | |
2176 | (cond ((memq (car args) '(:BEFORE :before)) | |
2177 | (setq args (cdr args)) | |
2178 | method-before) | |
2179 | ((memq (car args) '(:AFTER :after)) | |
2180 | (setq args (cdr args)) | |
2181 | method-after) | |
2182 | ((memq (car args) '(:STATIC :static)) | |
2183 | (setq args (cdr args)) | |
2184 | method-static) | |
2185 | ((memq (car args) '(:PRIMARY :primary)) | |
2186 | (setq args (cdr args)) | |
2187 | method-primary) | |
2188 | ;; Primary key. | |
2189 | (t method-primary))) | |
2190 | ;; Get body, and fix contents of args to be the arguments of the fn. | |
2191 | (setq body (cdr args) | |
2192 | args (car args)) | |
2193 | (setq loopa args) | |
2194 | ;; Create a fixed version of the arguments. | |
2195 | (while loopa | |
2196 | (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) | |
2197 | argfix)) | |
2198 | (setq loopa (cdr loopa))) | |
2199 | ;; Make sure there is a generic. | |
2200 | (eieio-defgeneric | |
2201 | method | |
2202 | (if (stringp (car body)) | |
2203 | (car body) (format "Generically created method `%s'." method))) | |
2204 | ;; create symbol for property to bind to. If the first arg is of | |
2205 | ;; the form (varname vartype) and `vartype' is a class, then | |
2206 | ;; that class will be the type symbol. If not, then it will fall | |
2207 | ;; under the type `primary' which is a non-specific calling of the | |
2208 | ;; function. | |
2209 | (setq firstarg (car args)) | |
2210 | (if (listp firstarg) | |
2211 | (progn | |
2212 | (setq argclass (nth 1 firstarg)) | |
2213 | (if (not (class-p argclass)) | |
2214 | (error "Unknown class type %s in method parameters" | |
2215 | (nth 1 firstarg)))) | |
2216 | ;; Generics are higher. | |
2217 | (setq key (eieio-specialized-key-to-generic-key key))) | |
2218 | ;; Put this lambda into the symbol so we can find it. | |
2219 | (if (byte-code-function-p (car-safe body)) | |
2220 | (eieiomt-add method (car-safe body) key argclass) | |
2221 | (eieiomt-add method (append (list 'lambda (reverse argfix)) body) | |
2222 | key argclass)) | |
2223 | ) | |
2224 | ||
2225 | (when eieio-optimize-primary-methods-flag | |
2226 | ;; Optimizing step: | |
2227 | ;; | |
2228 | ;; If this method, after this setup, only has primary methods, then | |
2229 | ;; we can setup the generic that way. | |
2230 | (if (generic-primary-only-p method) | |
2231 | ;; If there is only one primary method, then we can go one more | |
2232 | ;; optimization step. | |
2233 | (if (generic-primary-only-one-p method) | |
2234 | (eieio-defgeneric-reset-generic-form-primary-only-one method) | |
2235 | (eieio-defgeneric-reset-generic-form-primary-only method)) | |
2236 | (eieio-defgeneric-reset-generic-form method))) | |
2237 | ||
2238 | method) | |
2239 | (make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") | |
2240 | ||
2241 | (defun eieio-defgeneric (method doc-string) | |
2242 | "Obsolete work part of an old version of the `defgeneric' macro." | |
2243 | (if (and (fboundp method) (not (generic-p method)) | |
2244 | (or (byte-code-function-p (symbol-function method)) | |
2245 | (not (eq 'autoload (car (symbol-function method))))) | |
2246 | ) | |
2247 | (error "You cannot create a generic/method over an existing symbol: %s" | |
2248 | method)) | |
2249 | ;; Don't do this over and over. | |
2250 | (unless (fboundp 'method) | |
2251 | ;; This defun tells emacs where the first definition of this | |
2252 | ;; method is defined. | |
2253 | `(defun ,method nil) | |
2254 | ;; Make sure the method tables are installed. | |
2255 | (eieiomt-install method) | |
2256 | ;; Apply the actual body of this function. | |
2257 | (fset method (eieio-defgeneric-form method doc-string)) | |
2258 | ;; Return the method | |
2259 | 'method)) | |
2260 | (make-obsolete 'eieio-defgeneric nil "24.1") | |
2261 | ||
2262 | (provide 'eieio-core) | |
2263 | ||
2264 | ;;; eieio-core.el ends here |