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