Commit | Line | Data |
---|---|---|
1f1d88f5 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Layout for instances and vtables | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
11 | ;;; | |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Effective slot objects. | |
30 | ||
31 | (defclass effective-slot () | |
32 | ((class :initarg :class :type sod-slot :reader effective-slot-class) | |
33 | (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot) | |
77027cca | 34 | (initializer :initarg :initializer :type (or sod-initializer null) |
1f1d88f5 MW |
35 | :reader effective-slot-initializer)) |
36 | (:documentation | |
37 | "Describes a slot and how it's meant to be initialized. | |
38 | ||
39 | Effective slot objects are usually attached to layouts.")) | |
40 | ||
41 | (defgeneric find-slot-initializer (class slot) | |
42 | (:documentation | |
43 | "Return the most specific initializer for SLOT, starting from CLASS.")) | |
44 | ||
45 | (defgeneric compute-effective-slot (class slot) | |
46 | (:documentation | |
47 | "Construct an effective slot from the supplied direct slot. | |
48 | ||
49 | SLOT is a direct slot defined on CLASS or one of its superclasses. | |
50 | (Metaclass initializers are handled using a different mechanism.)")) | |
51 | ||
52 | (defmethod print-object ((slot effective-slot) stream) | |
53 | (maybe-print-unreadable-object (slot stream :type t) | |
54 | (format stream "~A~@[ = ~@_~A~]" | |
55 | (effective-slot-direct-slot slot) | |
56 | (effective-slot-initializer slot)))) | |
57 | ||
58 | (defmethod find-slot-initializer ((class sod-class) (slot sod-slot)) | |
59 | (some (lambda (super) | |
60 | (find slot | |
61 | (sod-class-instance-initializers super) | |
62 | :key #'sod-initializer-slot)) | |
63 | (sod-class-precedence-list class))) | |
64 | ||
65 | (defmethod compute-effective-slot ((class sod-class) (slot sod-slot)) | |
66 | (make-instance 'effective-slot | |
67 | :slot slot | |
68 | :class class | |
69 | :initializer (find-slot-initializer class slot))) | |
70 | ||
71 | ;;;-------------------------------------------------------------------------- | |
72 | ;;; Instance layout objects. | |
73 | ||
74 | ;;; islots | |
75 | ||
76 | (defclass islots () | |
77 | ((class :initarg :class :type sod-class :reader islots-class) | |
78 | (subclass :initarg :subclass :type sod-class :reader islots-subclass) | |
79 | (slots :initarg :slots :type list :reader islots-slots)) | |
80 | (:documentation | |
81 | "The collection of effective SLOTS defined by an instance of CLASS.")) | |
82 | ||
83 | (defmethod print-object ((islots islots) stream) | |
84 | (print-unreadable-object (islots stream :type t) | |
85 | (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" | |
86 | (islots-subclass islots) | |
87 | (islots-class islots) | |
88 | (islots-slots islots)))) | |
89 | ||
90 | (defgeneric compute-islots (class subclass) | |
91 | (:documentation | |
92 | "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS. | |
93 | ||
94 | Initializers for the slots should be taken from the most specific | |
95 | superclass of SUBCLASS.")) | |
96 | ||
97 | ;;; vtable-pointer | |
98 | ||
99 | (defclass vtable-pointer () | |
100 | ((class :initarg :class :type sod-class :reader vtable-pointer-class) | |
77027cca | 101 | (chain-head :initarg :chain-head :type sod-class |
ddee4bb1 MW |
102 | :reader vtable-pointer-chain-head) |
103 | (chain-tail :initarg :chain-tail :type sod-class | |
104 | :reader vtable-pointer-chain-tail)) | |
1f1d88f5 MW |
105 | (:documentation |
106 | "A pointer to the vtable for CLASS corresponding to a particular CHAIN.")) | |
107 | ||
108 | (defmethod print-object ((vtp vtable-pointer) stream) | |
109 | (print-unreadable-object (vtp stream :type t) | |
110 | (format stream "~A:~A" | |
111 | (vtable-pointer-class vtp) | |
112 | (sod-class-nickname (vtable-pointer-chain-head vtp))))) | |
113 | ||
114 | ;;; ichain | |
115 | ||
116 | (defclass ichain () | |
117 | ((class :initarg :class :type sod-class :reader ichain-class) | |
118 | (chain-head :initarg :chain-head :type sod-class :reader ichain-head) | |
ddee4bb1 | 119 | (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail) |
1f1d88f5 MW |
120 | (body :initarg :body :type list :reader ichain-body)) |
121 | (:documentation | |
122 | "All of the instance layout for CLASS corresponding to a particular CHAIN. | |
123 | ||
124 | The BODY is a list of things to include in the finished structure. By | |
125 | default, it contains a VTABLE-POINTER and ISLOTS for each class in the | |
126 | chain.")) | |
127 | ||
128 | (defmethod print-object ((ichain ichain) stream) | |
129 | (print-unreadable-object (ichain stream :type t) | |
130 | (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" | |
131 | (ichain-class ichain) | |
132 | (sod-class-nickname (ichain-head ichain)) | |
133 | (ichain-body ichain)))) | |
134 | ||
135 | (defgeneric compute-ichain (class chain) | |
136 | (:documentation | |
137 | "Return an ICHAIN for a particular CHAIN of CLASS's superclasses. | |
138 | ||
139 | The CHAIN is a list of classes, with the least specific first -- so the | |
140 | chain head is the first element.")) | |
141 | ||
142 | ;;; ilayout | |
143 | ||
144 | (defclass ilayout () | |
145 | ((class :initarg :class :type sod-class :reader ilayout-class) | |
146 | (ichains :initarg :ichains :type list :reader ilayout-ichains)) | |
147 | (:documentation | |
148 | "All of the instance layout for a CLASS. | |
149 | ||
150 | Consists of an ICHAIN for each distinct chain.")) | |
151 | ||
152 | (defmethod print-object ((ilayout ilayout) stream) | |
153 | (print-unreadable-object (ilayout stream :type t) | |
154 | (format stream "~A ~_~:<~@{~S~^ ~_~}~:>" | |
155 | (ilayout-class ilayout) | |
156 | (ilayout-ichains ilayout)))) | |
157 | ||
158 | (defgeneric compute-ilayout (class) | |
159 | (:documentation | |
160 | "Compute and return an instance layout for CLASS.")) | |
161 | ||
162 | ;;; Standard implementation. | |
163 | ||
164 | (defmethod compute-islots ((class sod-class) (subclass sod-class)) | |
165 | (make-instance 'islots | |
166 | :class class | |
167 | :subclass subclass | |
168 | :slots (mapcar (lambda (slot) | |
169 | (compute-effective-slot subclass slot)) | |
170 | (sod-class-slots class)))) | |
171 | ||
172 | (defmethod compute-ichain ((class sod-class) chain) | |
ddee4bb1 MW |
173 | (let* ((chain-head (car chain)) |
174 | (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) | |
175 | :key #'sod-class-chain-head)) | |
1f1d88f5 MW |
176 | (vtable-pointer (make-instance 'vtable-pointer |
177 | :class class | |
ddee4bb1 MW |
178 | :chain-head chain-head |
179 | :chain-tail chain-tail)) | |
1f1d88f5 MW |
180 | (islots (remove-if-not #'islots-slots |
181 | (mapcar (lambda (super) | |
182 | (compute-islots super class)) | |
183 | chain)))) | |
184 | (make-instance 'ichain | |
185 | :class class | |
ddee4bb1 MW |
186 | :chain-head chain-head |
187 | :chain-tail chain-tail | |
1f1d88f5 MW |
188 | :body (cons vtable-pointer islots)))) |
189 | ||
190 | (defmethod compute-ilayout ((class sod-class)) | |
191 | (make-instance 'ilayout | |
192 | :class class | |
193 | :ichains (mapcar (lambda (chain) | |
194 | (compute-ichain class | |
195 | (reverse chain))) | |
196 | (sod-class-chains class)))) | |
197 | ||
198 | ;;;-------------------------------------------------------------------------- | |
199 | ;;; Effective methods. | |
200 | ||
201 | (defclass effective-method () | |
77027cca | 202 | ((message :initarg :message :type sod-message |
1f1d88f5 | 203 | :reader effective-method-message) |
77027cca | 204 | (class :initarg :class :type sod-class :reader effective-method-class)) |
1f1d88f5 MW |
205 | (:documentation |
206 | "The effective method invoked by sending MESSAGE to an instance of CLASS. | |
207 | ||
208 | This is not a useful class by itself. Message classes are expected to | |
209 | define their own effective-method classes. | |
210 | ||
211 | An effective method class must accept a :DIRECT-METHODS initarg, which | |
212 | will be a list of applicable methods sorted in most-to-least specific | |
213 | order.")) | |
214 | ||
215 | (defmethod print-object ((method effective-method) stream) | |
216 | (maybe-print-unreadable-object (method stream :type t) | |
217 | (format stream "~A ~A" | |
218 | (effective-method-message method) | |
219 | (effective-method-class method)))) | |
220 | ||
221 | (defgeneric message-effective-method-class (message) | |
222 | (:documentation | |
223 | "Return the effective method class for the given MESSAGE.")) | |
224 | ||
225 | (defgeneric compute-sod-effective-method (message class) | |
226 | (:documentation | |
227 | "Return the effective method when a CLASS instance receives MESSAGE. | |
228 | ||
229 | The default method constructs an instance of the message's chosen | |
230 | MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the | |
231 | list of applicable methods as initargs to MAKE-INSTANCE.")) | |
232 | ||
233 | (defmethod compute-sod-effective-method | |
234 | ((message sod-message) (class sod-class)) | |
235 | (let ((direct-methods (mapcan (lambda (super) | |
236 | (let ((method | |
237 | (find message | |
238 | (sod-class-methods super) | |
239 | :key #'sod-method-message))) | |
240 | (and method (list method)))) | |
241 | (sod-class-precedence-list class)))) | |
242 | (make-instance (message-effective-method-class message) | |
243 | :message message | |
244 | :class class | |
245 | :direct-methods direct-methods))) | |
246 | ||
247 | ;;;-------------------------------------------------------------------------- | |
248 | ;;; Vtable layout. | |
249 | ||
250 | ;;; method-entry | |
251 | ||
252 | (defclass method-entry () | |
77027cca | 253 | ((method :initarg :method :type effective-method |
1f1d88f5 | 254 | :reader method-entry-effective-method) |
ddee4bb1 MW |
255 | (chain-head :initarg :chain-head :type sod-class |
256 | :reader method-entry-chain-head) | |
257 | (chain-tail :initarg :chain-tail :type sod-class | |
258 | :reader method-entry-chain-tail)) | |
1f1d88f5 MW |
259 | (:documentation |
260 | "An entry point into an effective method. | |
261 | ||
262 | Calls to an effective method via different vtable chains will have their | |
263 | `me' pointers pointing to different ichains within the instance layout. | |
264 | Rather than (necessarily) duplicating the entire effective method for each | |
265 | chain, we insert an entry veneer (the method entry) to fix up the pointer. | |
266 | Exactly how it does this is up to the effective method -- and duplication | |
267 | under some circumstances is probably a reasonable approach -- e.g., if the | |
268 | effective method is just going to call a direct method immediately.")) | |
269 | ||
270 | (defmethod print-object ((entry method-entry) stream) | |
271 | (maybe-print-unreadable-object (entry stream :type t) | |
272 | (format stream "~A:~A" | |
273 | (method-entry-effective-method entry) | |
274 | (sod-class-nickname (method-entry-chain-head entry))))) | |
275 | ||
ddee4bb1 | 276 | (defgeneric make-method-entry (effective-method chain-head chain-tail) |
1f1d88f5 MW |
277 | (:documentation |
278 | "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. | |
279 | ||
280 | There is no default method for this function. (Maybe when the | |
281 | effective-method/method-entry output protocol has settled down I'll know | |
282 | what a sensible default action would be.)")) | |
283 | ||
284 | ;;; vtmsgs | |
285 | ||
286 | (defclass vtmsgs () | |
287 | ((class :initarg :class :type sod-class :reader vtmsgs-class) | |
288 | (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass) | |
77027cca | 289 | (chain-head :initarg :chain-head :type sod-class |
1f1d88f5 | 290 | :reader vtmsgs-chain-head) |
ddee4bb1 MW |
291 | (chain-tail :initarg :chain-tail :type sod-class |
292 | :reader vtmsgs-chain-tail) | |
1f1d88f5 MW |
293 | (entries :initarg :entries :type list :reader vtmsgs-entries)) |
294 | (:documentation | |
295 | "The message dispatch table for a particular CLASS. | |
296 | ||
ddee4bb1 MW |
297 | The BODY contains a list of effective method entry objects for the |
298 | messages defined on CLASS, customized for calling from the chain headed by | |
1f1d88f5 MW |
299 | CHAIN-HEAD.")) |
300 | ||
301 | (defmethod print-object ((vtmsgs vtmsgs) stream) | |
302 | (print-unreadable-object (vtmsgs stream :type t) | |
303 | (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" | |
304 | (vtmsgs-subclass vtmsgs) | |
305 | (vtmsgs-class vtmsgs) | |
306 | (vtmsgs-entries vtmsgs)))) | |
307 | ||
ddee4bb1 | 308 | (defgeneric compute-vtmsgs (class subclass chain-head chain-tail) |
1f1d88f5 MW |
309 | (:documentation |
310 | "Return a VTMSGS object containing method entries for CLASS. | |
311 | ||
312 | The CHAIN-HEAD describes which chain the method entries should be | |
313 | constructed for. | |
314 | ||
315 | The default method simply calls MAKE-METHOD-ENTRY for each of the methods | |
316 | and wraps a VTMSGS object around them. This ought to be enough for almost | |
317 | all purposes.")) | |
318 | ||
319 | ;;; class-pointer | |
320 | ||
321 | (defclass class-pointer () | |
77027cca MW |
322 | ((class :initarg :class :type sod-class :reader class-pointer-class) |
323 | (chain-head :initarg :chain-head :type sod-class | |
1f1d88f5 | 324 | :reader class-pointer-chain-head) |
77027cca | 325 | (metaclass :initarg :metaclass :type sod-class |
1f1d88f5 | 326 | :reader class-pointer-metaclass) |
77027cca | 327 | (meta-chain-head :initarg :meta-chain-head :type sod-class |
1f1d88f5 MW |
328 | :reader class-pointer-meta-chain-head)) |
329 | (:documentation | |
330 | "Represents a pointer to a class object for the instance's class. | |
331 | ||
332 | A class instance can have multiple chains. It may be useful to find any | |
333 | of those chains from an instance of the class. Therefore the vtable | |
334 | stores a pointer to each separate chain of the class instance.")) | |
335 | ||
336 | (defmethod print-object ((cptr class-pointer) stream) | |
337 | (print-unreadable-object (cptr stream :type t) | |
338 | (format stream "~A:~A" | |
339 | (class-pointer-metaclass cptr) | |
340 | (sod-class-nickname (class-pointer-meta-chain-head cptr))))) | |
341 | ||
342 | (defgeneric make-class-pointer (class chain-head metaclass meta-chain-head) | |
343 | (:documentation | |
344 | "Return a class pointer to a metaclass chain.")) | |
345 | ||
346 | ;;; base-offset | |
347 | ||
348 | (defclass base-offset () | |
349 | ((class :initarg :class :type sod-class :reader base-offset-class) | |
77027cca | 350 | (chain-head :initarg :chain-head :type sod-class |
1f1d88f5 MW |
351 | :reader base-offset-chain-head)) |
352 | (:documentation | |
353 | "The offset of this chain to the ilayout base. | |
354 | ||
355 | There's only one of these per vtable.")) | |
356 | ||
357 | (defmethod print-object ((boff base-offset) stream) | |
358 | (print-unreadable-object (boff stream :type t) | |
359 | (format stream "~A:~A" | |
360 | (base-offset-class boff) | |
361 | (sod-class-nickname (base-offset-chain-head boff))))) | |
362 | ||
363 | (defgeneric make-base-offset (class chain-head) | |
364 | (:documentation | |
365 | "Return the base offset object for CHAIN-HEAD ichain.")) | |
366 | ||
367 | ;;; chain-offset | |
368 | ||
369 | (defclass chain-offset () | |
370 | ((class :initarg :class :type sod-class :reader chain-offset-class) | |
77027cca | 371 | (chain-head :initarg :chain-head :type sod-class |
1f1d88f5 | 372 | :reader chain-offset-chain-head) |
77027cca | 373 | (target-head :initarg :target-head :type sod-class |
1f1d88f5 MW |
374 | :reader chain-offset-target-head)) |
375 | (:documentation | |
376 | "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain.")) | |
377 | ||
378 | (defmethod print-object ((choff chain-offset) stream) | |
379 | (print-unreadable-object (choff stream :type t) | |
380 | (format stream "~A:~A->~A" | |
381 | (chain-offset-class choff) | |
382 | (sod-class-nickname (chain-offset-chain-head choff)) | |
383 | (sod-class-nickname (chain-offset-target-head choff))))) | |
384 | ||
385 | (defgeneric make-chain-offset (class chain-head target-head) | |
386 | (:documentation | |
387 | "Return the offset from CHAIN-HEAD to TARGET-HEAD.")) | |
388 | ||
389 | ;;; vtable | |
390 | ||
391 | (defclass vtable () | |
392 | ((class :initarg :class :type sod-class :reader vtable-class) | |
77027cca | 393 | (chain-head :initarg :chain-head :type sod-class |
1f1d88f5 | 394 | :reader vtable-chain-head) |
ddee4bb1 MW |
395 | (chain-tail :initarg :chain-tail :type sod-class |
396 | :reader vtable-chain-tail) | |
1f1d88f5 MW |
397 | (body :initarg :body :type list :reader vtable-body)) |
398 | (:documentation | |
399 | "VTABLEs hold all of the per-chain static information for a class. | |
400 | ||
401 | There is one vtable for each chain of each class. The vtables for a class | |
402 | are prefixes of the corresponding chains of its subclasses. | |
403 | ||
404 | Vtables contain method entry pointers, pointers to class objects, and | |
405 | the offset information used for cross-chain slot access.")) | |
406 | ||
407 | (defmethod print-object ((vtable vtable) stream) | |
408 | (print-unreadable-object (vtable stream :type t) | |
409 | (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" | |
410 | (vtable-class vtable) | |
411 | (sod-class-nickname (vtable-chain-head vtable)) | |
412 | (vtable-body vtable)))) | |
413 | ||
414 | (defgeneric compute-vtable (class chain) | |
415 | (:documentation | |
416 | "Compute the vtable layout for a chain of CLASS. | |
417 | ||
418 | The CHAIN is a list of classes, with the least specific first.")) | |
419 | ||
420 | (defgeneric compute-vtables (class) | |
421 | (:documentation | |
422 | "Compute the vtable layouts for CLASS. | |
423 | ||
424 | Returns a list of VTABLE objects in the order of CLASS's chains.")) | |
425 | ||
426 | ;;; Implementation. | |
427 | ||
428 | (defmethod compute-vtmsgs | |
429 | ((class sod-class) | |
430 | (subclass sod-class) | |
ddee4bb1 MW |
431 | (chain-head sod-class) |
432 | (chain-tail sod-class)) | |
1f1d88f5 MW |
433 | (flet ((make-entry (message) |
434 | (let ((method (find message | |
435 | (sod-class-effective-methods subclass) | |
436 | :key #'effective-method-message))) | |
ddee4bb1 | 437 | (make-method-entry method chain-head chain-tail)))) |
1f1d88f5 MW |
438 | (make-instance 'vtmsgs |
439 | :class class | |
440 | :subclass subclass | |
441 | :chain-head chain-head | |
ddee4bb1 | 442 | :chain-tail chain-tail |
1f1d88f5 MW |
443 | :entries (mapcar #'make-entry |
444 | (sod-class-messages class))))) | |
445 | ||
446 | (defmethod make-class-pointer | |
447 | ((class sod-class) (chain-head sod-class) | |
448 | (metaclass sod-class) (meta-chain-head sod-class)) | |
449 | ||
450 | ;; Slightly tricky. We don't necessarily want a pointer to the metaclass, | |
451 | ;; but to its most specific subclass on the given chain. Fortunately, CL | |
452 | ;; is good at this game. | |
453 | (let* ((meta-chains (sod-class-chains metaclass)) | |
454 | (meta-chain-tails (mapcar #'car meta-chains)) | |
455 | (meta-chain-tail (find meta-chain-head meta-chain-tails | |
456 | :key #'sod-class-chain-head))) | |
457 | (make-instance 'class-pointer | |
458 | :class class | |
459 | :chain-head chain-head | |
460 | :metaclass meta-chain-tail | |
461 | :meta-chain-head meta-chain-head))) | |
462 | ||
463 | (defmethod make-base-offset ((class sod-class) (chain-head sod-class)) | |
464 | (make-instance 'base-offset | |
465 | :class class | |
466 | :chain-head chain-head)) | |
467 | ||
468 | (defmethod make-chain-offset | |
469 | ((class sod-class) (chain-head sod-class) (target-head sod-class)) | |
470 | (make-instance 'chain-offset | |
471 | :class class | |
472 | :chain-head chain-head | |
473 | :target-head target-head)) | |
474 | ||
475 | ;; Special variables used by COMPUTE-VTABLE. | |
476 | (defvar *done-metaclass-chains*) | |
477 | (defvar *done-instance-chains*) | |
478 | ||
ddee4bb1 | 479 | (defgeneric compute-vtable-items (class super chain-head chain-tail emit) |
1f1d88f5 MW |
480 | (:documentation |
481 | "Emit vtable items for a superclass of CLASS. | |
482 | ||
483 | This function is called for each superclass SUPER of CLASS reached on the | |
484 | chain headed by CHAIN-HEAD. The function should call EMIT for each | |
485 | vtable item it wants to write. | |
486 | ||
487 | The right way to check to see whether items have already been emitted | |
488 | (e.g., has an offset to some other chain been emitted?) is as follows: | |
489 | ||
490 | * In a method on COMPUTE-VTABLE, bind a special variable to an empty | |
491 | list or hash table. | |
492 | ||
493 | * In a method on this function, check the variable or hash table. | |
494 | ||
495 | This function is the real business end of COMPUTE-VTABLE.")) | |
496 | ||
497 | (defmethod compute-vtable-items | |
498 | ((class sod-class) (super sod-class) (chain-head sod-class) | |
ddee4bb1 | 499 | (chain-tail sod-class) (emit function)) |
1f1d88f5 MW |
500 | |
501 | ;; If this class introduces new metaclass chains, then emit pointers to | |
502 | ;; them. | |
503 | (let* ((metasuper (sod-class-metaclass super)) | |
504 | (metasuper-chains (sod-class-chains metasuper)) | |
505 | (metasuper-chain-heads (mapcar (lambda (chain) | |
506 | (sod-class-chain-head (car chain))) | |
507 | metasuper-chains))) | |
508 | (dolist (metasuper-chain-head metasuper-chain-heads) | |
509 | (unless (member metasuper-chain-head *done-metaclass-chains*) | |
510 | (funcall emit (make-class-pointer class | |
511 | chain-head | |
512 | metasuper | |
513 | metasuper-chain-head)) | |
514 | (push metasuper-chain-head *done-metaclass-chains*)))) | |
515 | ||
516 | ;; If there are new instance chains, then emit offsets to them. | |
517 | (let* ((chains (sod-class-chains super)) | |
518 | (chain-heads (mapcar (lambda (chain) | |
519 | (sod-class-chain-head (car chain))) | |
520 | chains))) | |
521 | (dolist (head chain-heads) | |
522 | (unless (member head *done-instance-chains*) | |
523 | (funcall emit (make-chain-offset class chain-head head)) | |
524 | (push head *done-instance-chains*)))) | |
525 | ||
526 | ;; Finally, if there are interesting methods, emit those too. | |
527 | (when (sod-class-messages super) | |
ddee4bb1 MW |
528 | (funcall emit (compute-vtmsgs super class chain-head chain-tail)))) |
529 | ||
530 | (defun find-root-superclass (class) | |
531 | "Returns the `root' superclass of CLASS. | |
532 | ||
533 | The root superclass is the superclass which itself has no direct | |
534 | superclasses. In universes not based on the provided builtin module, the | |
535 | root class may not be our beloved SodObject; however, there must be one | |
536 | (otherwise the class graph is cyclic, which should be forbidden), and we | |
537 | instist that it be unique." | |
538 | ||
539 | ;; The root superclass must be a chain head since the chains partition the | |
540 | ;; superclasses; the root has no superclasses so it can't have a link and | |
541 | ;; must therefore be a head. This narrows the field down quite a lot. | |
542 | ;; | |
543 | ;; Note! This function gets called from CHECK-SOD-CLASS before the class's | |
544 | ;; chains have been computed. Therefore we iterate over the direct | |
545 | ;; superclass's chains rather than the class's own. This misses a chain | |
546 | ;; only in the case where the class is its own chain head. There are two | |
547 | ;; subcases: if there are no direct superclasses at all, then the class is | |
548 | ;; its own root; otherwise, it clearly can't be the root and the omission | |
549 | ;; is harmless. | |
550 | (let* ((supers (sod-class-direct-superclasses class)) | |
551 | (roots (if supers | |
552 | (remove-if #'sod-class-direct-superclasses | |
553 | (mapcar (lambda (super) | |
554 | (sod-class-chain-head super)) | |
555 | supers)) | |
556 | (list class)))) | |
557 | (cond ((null roots) (error "Class ~A has no root class!" class)) | |
558 | ((cdr roots) (error "Class ~A has multiple root classes ~ | |
559 | ~{~A~#[~; and ~;, ~]~}" | |
560 | class roots)) | |
561 | (t (car roots))))) | |
562 | ||
563 | (defun find-root-metaclass (class) | |
564 | "Returns the `root' metaclass of CLASS. | |
565 | ||
566 | The root metaclass is the metaclass of the root superclass -- see | |
567 | FIND-ROOT-SUPERCLASS." | |
568 | (sod-class-metaclass (find-root-superclass class))) | |
1f1d88f5 MW |
569 | |
570 | (defmethod compute-vtable ((class sod-class) (chain list)) | |
571 | (let* ((chain-head (car chain)) | |
ddee4bb1 MW |
572 | (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) |
573 | :key #'sod-class-chain-head)) | |
1f1d88f5 MW |
574 | (*done-metaclass-chains* nil) |
575 | (*done-instance-chains* (list chain-head)) | |
576 | (done-superclasses nil) | |
577 | (items nil)) | |
578 | (flet ((emit (item) | |
579 | (push item items))) | |
580 | ||
581 | ;; Find the root chain in the metaclass and write a pointer. | |
582 | (let* ((metaclass (sod-class-metaclass class)) | |
ddee4bb1 MW |
583 | (metaclass-root (find-root-metaclass class)) |
584 | (metaclass-root-head (sod-class-chain-head metaclass-root))) | |
585 | (emit (make-class-pointer class chain-head metaclass | |
586 | metaclass-root-head)) | |
587 | (push metaclass-root-head *done-metaclass-chains*)) | |
1f1d88f5 MW |
588 | |
589 | ;; Write an offset to the instance base. | |
590 | (emit (make-base-offset class chain-head)) | |
591 | ||
592 | ;; Now walk the chain. As we ascend the chain, scan the class | |
593 | ;; precedence list of each class in reverse to ensure that we have | |
594 | ;; everything interesting. | |
595 | (dolist (super chain) | |
596 | (dolist (sub (reverse (sod-class-precedence-list super))) | |
597 | (unless (member sub done-superclasses) | |
598 | (compute-vtable-items class | |
599 | sub | |
600 | chain-head | |
ddee4bb1 | 601 | chain-tail |
1f1d88f5 MW |
602 | #'emit) |
603 | (push sub done-superclasses)))) | |
604 | ||
605 | ;; We're through. | |
606 | (make-instance 'vtable | |
607 | :class class | |
608 | :chain-head chain-head | |
ddee4bb1 | 609 | :chain-tail chain-tail |
1f1d88f5 MW |
610 | :body (nreverse items))))) |
611 | ||
612 | (defgeneric compute-effective-methods (class) | |
613 | (:documentation | |
614 | "Return a list of all of the effective methods needed for CLASS. | |
615 | ||
616 | The list needn't be in any particular order.")) | |
617 | ||
618 | (defmethod compute-effective-methods ((class sod-class)) | |
619 | (mapcan (lambda (super) | |
620 | (mapcar (lambda (message) | |
621 | (compute-sod-effective-method message class)) | |
622 | (sod-class-messages super))) | |
623 | (sod-class-precedence-list class))) | |
624 | ||
625 | (defmethod compute-vtables ((class sod-class)) | |
626 | (mapcar (lambda (chain) | |
627 | (compute-vtable class (reverse chain))) | |
628 | (sod-class-chains class))) | |
629 | ||
630 | ;;;-------------------------------------------------------------------------- | |
631 | ;;; Names of things. | |
632 | ||
633 | (defun islots-struct-tag (class) | |
634 | (format nil "~A__islots" class)) | |
635 | ||
636 | (defun ichain-struct-tag (class chain-head) | |
ddee4bb1 MW |
637 | (format nil "~A__ichain_~A" class (sod-class-nickname chain-head))) |
638 | ||
639 | (defun ichain-union-tag (class chain-head) | |
640 | (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head))) | |
1f1d88f5 MW |
641 | |
642 | (defun ilayout-struct-tag (class) | |
643 | (format nil "~A__ilayout" class)) | |
644 | ||
645 | (defun vtmsgs-struct-tag (class super) | |
646 | (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) | |
647 | ||
648 | (defun vtable-struct-tag (class chain-head) | |
649 | (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) | |
650 | ||
651 | (defun vtable-name (class chain-head) | |
652 | (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) | |
653 | ||
1f1d88f5 | 654 | ;;;----- That's all, folks -------------------------------------------------- |