3 ;;; Class layout protocol implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (defmethod print-object ((slot effective-slot) stream)
32 (maybe-print-unreadable-object (slot stream :type t)
33 (format stream "~A~@[ = ~@_~A~]"
34 (effective-slot-direct-slot slot)
35 (effective-slot-initializer slot))))
37 (defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
40 (sod-class-instance-initializers super)
41 :key #'sod-initializer-slot))
42 (sod-class-precedence-list class)))
44 (defmethod find-slot-initargs ((class sod-class) (slot sod-slot))
45 (mappend (lambda (super)
46 (remove-if-not (lambda (initarg)
47 (and (typep initarg 'sod-slot-initarg)
48 (eq (sod-initarg-slot initarg) slot)))
49 (sod-class-initargs super)))
50 (sod-class-precedence-list class)))
52 (defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
53 (make-instance 'effective-slot
56 :initializer (find-slot-initializer class slot)
57 :initargs (find-slot-initargs class slot)))
59 (defmethod find-class-initializer ((slot effective-slot) (class sod-class))
60 (let ((dslot (effective-slot-direct-slot slot)))
61 (or (some (lambda (super)
62 (find dslot (sod-class-class-initializers super)
63 :key #'sod-initializer-slot))
64 (sod-class-precedence-list class))
65 (effective-slot-initializer slot))))
67 ;;;--------------------------------------------------------------------------
68 ;;; Special-purpose slot objects.
70 (export '(sod-class-slot
71 sod-slot-initializer-function sod-slot-prepare-function))
72 (defclass sod-class-slot (sod-slot)
73 ((initializer-function :initarg :initializer-function
74 :type (or symbol function)
75 :reader sod-slot-initializer-function)
76 (prepare-function :initarg :prepare-function :type (or symbol function)
77 :reader sod-slot-prepare-function))
79 "Special class for slots defined on `SodClass'.
81 These slots need class-specific initialization. It's easier to keep all
82 of the information (name, type, and how to initialize them) about these
83 slots in one place, so that's what we do here."))
85 (defmethod shared-initialize :after
86 ((slot sod-class-slot) slot-names &key pset)
87 (declare (ignore slot-names))
88 (default-slot (slot 'initializer-function)
89 (get-property pset :initializer-function :func nil))
90 (default-slot (slot 'prepare-function)
91 (get-property pset :prepare-function :func nil)))
93 (export '(sod-class-effective-slot
94 effective-slot-initializer-function
95 effective-slot-prepare-function))
96 (defclass sod-class-effective-slot (effective-slot)
97 ((initializer-function :initarg :initializer-function
98 :type (or symbol function)
99 :reader effective-slot-initializer-function)
100 (prepare-function :initarg :prepare-function :type (or symbol function)
101 :reader effective-slot-prepare-function))
103 "Special class for slots defined on `SodClass'.
105 This class ignores any explicit initializers and computes initializer
106 values using the slot's INIT-FUNC slot and a magical protocol during
107 metaclass instance construction."))
109 (defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
110 (make-instance 'sod-class-effective-slot
111 :class class :slot slot
112 :initializer-function (sod-slot-initializer-function slot)
113 :prepare-function (sod-slot-prepare-function slot)
114 :initializer (find-slot-initializer class slot)))
116 ;;;--------------------------------------------------------------------------
117 ;;; Effective methods.
119 (defmethod print-object ((method effective-method) stream)
120 (maybe-print-unreadable-object (method stream :type t)
121 (format stream "~A ~A"
122 (effective-method-message method)
123 (effective-method-class method))))
125 (defmethod print-object ((entry method-entry) stream)
126 (maybe-print-unreadable-object (entry stream :type t)
127 (format stream "~A:~A~@[ ~S~]"
128 (method-entry-effective-method entry)
129 (sod-class-nickname (method-entry-chain-head entry))
130 (method-entry-role entry))))
132 (defmethod sod-message-applicable-methods
133 ((message sod-message) (class sod-class))
134 (mappend (lambda (super)
136 (sod-class-methods super)
137 :key #'sod-method-message
139 (sod-class-precedence-list class)))
141 (defmethod compute-sod-effective-method
142 ((message sod-message) (class sod-class))
143 (let ((direct-methods (sod-message-applicable-methods message class)))
144 (make-instance (sod-message-effective-method-class message)
147 :direct-methods direct-methods)))
149 (defmethod compute-effective-methods ((class sod-class))
150 (mapcan (lambda (super)
151 (mapcar (lambda (message)
152 (compute-sod-effective-method message class))
153 (sod-class-messages super)))
154 (sod-class-precedence-list class)))
156 ;;;--------------------------------------------------------------------------
161 (defmethod print-object ((islots islots) stream)
162 (print-unreadable-object (islots stream :type t)
163 (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
164 (islots-subclass islots)
165 (islots-class islots)
166 (islots-slots islots))))
168 (defmethod compute-islots ((class sod-class) (subclass sod-class))
169 (make-instance 'islots
172 :slots (mapcar (lambda (slot)
173 (compute-effective-slot subclass slot))
174 (sod-class-slots class))))
177 ;;; Do we need a construction protocol here?
179 (defmethod print-object ((vtp vtable-pointer) stream)
180 (print-unreadable-object (vtp stream :type t)
181 (format stream "~A:~A"
182 (vtable-pointer-class vtp)
183 (sod-class-nickname (vtable-pointer-chain-head vtp)))))
187 (defmethod print-object ((ichain ichain) stream)
188 (print-unreadable-object (ichain stream :type t)
189 (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
190 (ichain-class ichain)
191 (sod-class-nickname (ichain-head ichain))
192 (ichain-body ichain))))
194 (defmethod compute-ichain ((class sod-class) chain)
195 (let* ((chain-head (car chain))
196 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
197 :key #'sod-class-chain-head))
198 (vtable-pointer (make-instance 'vtable-pointer
200 :chain-head chain-head
201 :chain-tail chain-tail))
202 (islots (remove-if-not #'islots-slots
203 (mapcar (lambda (super)
204 (compute-islots super class))
206 (make-instance 'ichain
208 :chain-head chain-head
209 :chain-tail chain-tail
210 :body (cons vtable-pointer islots))))
214 (defmethod print-object ((ilayout ilayout) stream)
215 (print-unreadable-object (ilayout stream :type t)
216 (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
217 (ilayout-class ilayout)
218 (ilayout-ichains ilayout))))
220 (defmethod compute-ilayout ((class sod-class))
221 (make-instance 'ilayout
223 :ichains (mapcar (lambda (chain)
224 (compute-ichain class
226 (sod-class-chains class))))
228 ;;;--------------------------------------------------------------------------
233 (defmethod print-object ((vtmsgs vtmsgs) stream)
234 (print-unreadable-object (vtmsgs stream :type t)
235 (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
236 (vtmsgs-subclass vtmsgs)
237 (vtmsgs-class vtmsgs)
238 (vtmsgs-entries vtmsgs))))
240 (defmethod compute-vtmsgs
243 (chain-head sod-class)
244 (chain-tail sod-class))
245 (flet ((make-entries (message)
246 (let ((method (find message
247 (sod-class-effective-methods subclass)
248 :key #'effective-method-message)))
249 (make-method-entries method chain-head chain-tail))))
250 (make-instance 'vtmsgs
253 :chain-head chain-head
254 :chain-tail chain-tail
255 :entries (mapcan #'make-entries
256 (sod-class-messages class)))))
260 (defmethod print-object ((cptr class-pointer) stream)
261 (print-unreadable-object (cptr stream :type t)
262 (format stream "~A:~A"
263 (class-pointer-metaclass cptr)
264 (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
266 (defmethod make-class-pointer
267 ((class sod-class) (chain-head sod-class)
268 (metaclass sod-class) (meta-chain-head sod-class))
270 ;; Rather tricky. This is a class pointer on a vtable for the CHAIN-HEAD
271 ;; chain, pointing into the META-CHAIN-HEAD chain of the metaclass. We
272 ;; need to produce a pointer to the most specific superclass of the
273 ;; metaclass on the right chain that is a superclass of the metaclass of
274 ;; the most specific class in the superclass chain headed by CHAIN-HEAD.
275 (flet ((chain-tail (class head)
276 (find head (mapcar #'car (sod-class-chains class))
277 :key #'sod-class-chain-head)))
278 (make-instance 'class-pointer
279 :class class :chain-head chain-head
280 :metaclass (chain-tail (sod-class-metaclass
281 (chain-tail class chain-head))
283 :meta-chain-head meta-chain-head)))
287 (defmethod print-object ((boff base-offset) stream)
288 (print-unreadable-object (boff stream :type t)
289 (format stream "~A:~A"
290 (base-offset-class boff)
291 (sod-class-nickname (base-offset-chain-head boff)))))
293 (defmethod make-base-offset ((class sod-class) (chain-head sod-class))
294 (make-instance 'base-offset
296 :chain-head chain-head))
300 (defmethod print-object ((choff chain-offset) stream)
301 (print-unreadable-object (choff stream :type t)
302 (format stream "~A:~A->~A"
303 (chain-offset-class choff)
304 (sod-class-nickname (chain-offset-chain-head choff))
305 (sod-class-nickname (chain-offset-target-head choff)))))
307 (defmethod make-chain-offset
308 ((class sod-class) (chain-head sod-class) (target-head sod-class))
309 (make-instance 'chain-offset
311 :chain-head chain-head
312 :target-head target-head))
316 (defmethod print-object ((vtable vtable) stream)
317 (print-unreadable-object (vtable stream :type t)
318 (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
319 (vtable-class vtable)
320 (sod-class-nickname (vtable-chain-head vtable))
321 (vtable-body vtable))))
323 ;; Special variables used by `compute-vtable'.
324 (defvar *done-metaclass-chains*)
325 (defvar *done-instance-chains*)
327 (defmethod compute-vtable-items
328 ((class sod-class) (super sod-class) (chain-head sod-class)
329 (chain-tail sod-class) (emit function))
331 ;; If this class introduces new metaclass chains, then emit pointers to
333 (let* ((metaclass (sod-class-metaclass class))
334 (metasuper (sod-class-metaclass super))
335 (metasuper-chains (sod-class-chains metasuper))
336 (metasuper-chain-heads (mapcar (lambda (chain)
337 (sod-class-chain-head (car chain)))
339 (dolist (metasuper-chain-head metasuper-chain-heads)
340 (unless (member metasuper-chain-head *done-metaclass-chains*)
341 (funcall emit (make-class-pointer class
344 metasuper-chain-head))
345 (push metasuper-chain-head *done-metaclass-chains*))))
347 ;; If there are new instance chains, then emit offsets to them.
348 (let* ((chains (sod-class-chains super))
349 (chain-heads (mapcar (lambda (chain)
350 (sod-class-chain-head (car chain)))
352 (dolist (head chain-heads)
353 (unless (member head *done-instance-chains*)
354 (funcall emit (make-chain-offset class chain-head head))
355 (push head *done-instance-chains*))))
357 ;; Finally, if there are interesting methods, emit those too.
358 (when (sod-class-messages super)
359 (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
361 (defmethod compute-vtable ((class sod-class) (chain list))
362 (let* ((chain-head (car chain))
363 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
364 :key #'sod-class-chain-head))
365 (*done-metaclass-chains* nil)
366 (*done-instance-chains* (list chain-head))
367 (done-superclasses nil)
372 ;; Find the root chain in the metaclass and write a pointer.
373 (let* ((metaclass (sod-class-metaclass class))
374 (metaclass-root (find-root-metaclass class))
375 (metaclass-root-head (sod-class-chain-head metaclass-root)))
376 (emit (make-class-pointer class chain-head metaclass
377 metaclass-root-head))
378 (push metaclass-root-head *done-metaclass-chains*))
380 ;; Write an offset to the instance base.
381 (emit (make-base-offset class chain-head))
383 ;; Now walk the chain. As we ascend the chain, scan the class
384 ;; precedence list of each class in reverse to ensure that we have
385 ;; everything interesting.
386 (dolist (super chain)
387 (dolist (sub (reverse (sod-class-precedence-list super)))
388 (unless (member sub done-superclasses)
389 (compute-vtable-items class
394 (push sub done-superclasses))))
397 (make-instance 'vtable
399 :chain-head chain-head
400 :chain-tail chain-tail
401 :body (nreverse items)))))
403 (defmethod compute-vtables ((class sod-class))
404 (mapcar (lambda (chain)
405 (compute-vtable class (reverse chain)))
406 (sod-class-chains class)))
408 ;;;--------------------------------------------------------------------------
409 ;;; Layout interface.
411 ;; Just arrange to populate the necessary slots on demand.
412 (flet ((check-class-is-finalized (class)
413 (unless (eq (sod-class-state class) :finalized)
414 (error "Class ~S is not finalized" class))))
415 (macrolet ((define-layout-slot (slot (class) &body body)
416 `(define-on-demand-slot sod-class ,slot (,class)
417 (check-class-is-finalized ,class)
419 (define-layout-slot %ilayout (class)
420 (compute-ilayout class))
421 (define-layout-slot effective-methods (class)
422 (compute-effective-methods class))
423 (define-layout-slot vtables (class)
424 (compute-vtables class))))
426 ;;;----- That's all, folks --------------------------------------------------