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