~mdw / sod / blob
? search:


d914864baa13410af4fe3943dc42e30638b78a3b
[sod] / src / class-output.lisp
1 ;;; -*-lisp-*-
2 ;;;
3 ;;; Output for classes
4 ;;;
5 ;;; (c) 2009 Straylight/Edgeware
6 ;;;
7
8 ;;;----- Licensing notice ---------------------------------------------------
9 ;;;
10 ;;; This file is part of the Sensble Object Design, an object system for C.
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 ;;; Classes.
30
31 (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
32
33 ;; Main output sequencing.
34 (sequence-output (stream sequencer)
35
36 :constraint
37 ((:classes :start)
38 (class :banner)
39 (class :islots :start) (class :islots :slots) (class :islots :end)
40 (class :vtmsgs :start) (class :vtmsgs :end)
41 (class :vtables :start) (class :vtables :end)
42 (class :vtable-externs) (class :vtable-externs-after)
43 (class :methods :start) (class :methods) (class :methods :end)
44 (class :ichains :start) (class :ichains :end)
45 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
46 (class :conversions)
47 (class :message-macros)
48 (class :object)
49 (:classes :end))
50
51 (:typedefs
52 (format stream "typedef struct ~A ~A;~%"
53 (ichain-struct-tag class (sod-class-chain-head class)) class))
54
55 ((class :banner)
56 (banner (format nil "Class ~A" class) stream))
57 ((class :vtable-externs-after)
58 (terpri stream))
59
60 ((class :vtable-externs)
61 (format stream "/* Vtable structures. */~%"))
62
63 ((class :object)
64 (let ((metaclass (sod-class-metaclass class))
65 (metaroot (find-root-metaclass class)))
66 (format stream "/* The class object. */~@
67 extern const struct ~A ~A__classobj;~@
68 #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
69 (ilayout-struct-tag metaclass) class
70 (sod-class-nickname (sod-class-chain-head metaroot))
71 (sod-class-nickname metaroot)))))
72
73 ;; Maybe generate an islots structure.
74 (when (sod-class-slots class)
75 (dolist (slot (sod-class-slots class))
76 (hook-output slot 'islots sequencer))
77 (sequence-output (stream sequencer)
78 ((class :islots :start)
79 (format stream "/* Instance slots. */~@
80 struct ~A {~%"
81 (islots-struct-tag class)))
82 ((class :islots :end)
83 (format stream "};~2%"))))
84
85 ;; Declare the direct methods.
86 (when (sod-class-methods class)
87 (sequence-output (stream sequencer)
88 ((class :methods :start)
89 (format stream "/* Direct methods. */~%"))
90 ((class :methods :end)
91 (terpri stream))))
92
93 ;; Provide upcast macros which do the right thing.
94 (when (sod-class-direct-superclasses class)
95 (sequence-output (stream sequencer)
96 ((class :conversions)
97 (let ((chain-head (sod-class-chain-head class)))
98 (format stream "/* Conversion macros. */~%")
99 (dolist (super (cdr (sod-class-precedence-list class)))
100 (let ((super-head (sod-class-chain-head super)))
101 (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
102 ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
103 class (sod-class-nickname super) super
104 (eq chain-head super-head)
105 (sod-class-nickname super-head))))
106 (terpri stream)))))
107
108 ;; Provide convenience macros for sending the newly defined messages. (The
109 ;; macros work on all subclasses too.)
110 ;;
111 ;; We need each message's method entry type for this, so we need to dig it
112 ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
113 ;; entries for precisely the messages we want to make macros for.
114 (when (sod-class-messages class)
115 (sequence-output (stream sequencer)
116 ((class :message-macros)
117 (let* ((vtable (find (sod-class-chain-head class)
118 (sod-class-vtables class)
119 :key #'vtable-chain-head))
120 (vtmsgs (find-if (lambda (item)
121 (and (typep item 'vtmsgs)
122 (eql (vtmsgs-class item) class)))
123 (vtable-body vtable))))
124 (format stream "/* Message invocation macros. */~%")
125 (dolist (entry (vtmsgs-entries vtmsgs))
126 (let* ((type (method-entry-function-type entry))
127 (args (c-function-arguments type))
128 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
129 (do ((args args (cdr args)))
130 ((endp args))
131 (let* ((raw-name (princ-to-string (argument-name (car args))))
132 (name (if (find raw-name
133 (list "_vt"
134 (sod-class-nickname class)
135 (method-entry-slot-name entry))
136 :test #'string=)
137 (format nil "sod__a_~A" raw-name)
138 raw-name)))
139 (cond ((and (cdr args) (eq (cadr args) :ellipsis))
140 (setf varargsp t)
141 (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
142 (push (format nil "/*~A*/ ..." name) in-names)
143 (push "__VA_ARGS__" out-names)
144 (return))
145 (t
146 (push name in-names)
147 (push name out-names)))))
148 (when varargsp
149 (format stream "#if __STDC_VERSION__ >= 199901~%"))
150 (format stream "#define ~A(~{~A~^, ~}) ~
151 ~A->_vt->~A.~A(~{~A~^, ~})~%"
152 (message-macro-name class entry)
153 (nreverse in-names)
154 me
155 (sod-class-nickname class)
156 (method-entry-slot-name entry)
157 (nreverse out-names))
158 (when varargsp
159 (format stream "#endif~%"))))
160 (terpri stream)))))
161
162 ;; Generate vtmsgs structure for all superclasses.
163 (hook-output (car (sod-class-vtables class))
164 'vtmsgs
165 sequencer))
166
167 (defmethod hook-output progn ((class sod-class) reason sequencer)
168 (with-slots (ilayout vtables methods effective-methods) class
169 (hook-output ilayout reason sequencer)
170 (dolist (method methods) (hook-output method reason sequencer))
171 (dolist (method effective-methods) (hook-output method reason sequencer))
172 (dolist (vtable vtables) (hook-output vtable reason sequencer))))
173
174 ;;;--------------------------------------------------------------------------
175 ;;; Instance structure.
176
177 (defmethod hook-output progn ((slot sod-slot)
178 (reason (eql 'islots))
179 sequencer)
180 (sequence-output (stream sequencer)
181 (((sod-slot-class slot) :islots :slots)
182 (pprint-logical-block (stream nil :prefix " " :suffix ";")
183 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
184 (terpri stream))))
185
186 (defmethod hook-output progn ((ilayout ilayout) reason sequencer)
187 (with-slots (ichains) ilayout
188 (dolist (ichain ichains) (hook-output ichain reason sequencer))))
189
190 (defmethod hook-output progn ((ichain ichain) reason sequencer)
191 (dolist (item (ichain-body ichain))
192 (hook-output item reason sequencer)))
193
194 (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer)
195 (with-slots (class ichains) ilayout
196 (sequence-output (stream sequencer)
197 ((class :ilayout :start)
198 (format stream "/* Instance layout. */~@
199 struct ~A {~%"
200 (ilayout-struct-tag class)))
201 ((class :ilayout :end)
202 (format stream "};~2%")))
203 (dolist (ichain ichains)
204 (hook-output ichain 'ilayout sequencer))))
205
206 (defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer)
207 (with-slots (class chain-head chain-tail) ichain
208 (when (eq class chain-tail)
209 (sequence-output (stream sequencer)
210 :constraint ((class :ichains :start)
211 (class :ichain chain-head :start)
212 (class :ichain chain-head :slots)
213 (class :ichain chain-head :end)
214 (class :ichains :end))
215 ((class :ichain chain-head :start)
216 (format stream "/* Instance chain structure. */~@
217 struct ~A {~%"
218 (ichain-struct-tag chain-tail chain-head)))
219 ((class :ichain chain-head :end)
220 (format stream "};~2%")
221 (format stream "/* Union of equivalent superclass chains. */~@
222 union ~A {~@
223 ~:{ struct ~A ~A;~%~}~
224 };~2%"
225 (ichain-union-tag chain-tail chain-head)
226
227 ;; Make sure the most specific class is first: only the
228 ;; first element of a union can be statically initialized in
229 ;; C90.
230 (mapcar (lambda (super)
231 (list (ichain-struct-tag super chain-head)
232 (sod-class-nickname super)))
233 (sod-class-chain chain-tail))))))))
234
235 (defmethod hook-output progn ((ichain ichain)
236 (reason (eql 'ilayout))
237 sequencer)
238 (with-slots (class chain-head chain-tail) ichain
239 (sequence-output (stream sequencer)
240 ((class :ilayout :slots)
241 (format stream " union ~A ~A;~%"
242 (ichain-union-tag chain-tail chain-head)
243 (sod-class-nickname chain-head))))))
244
245 (defmethod hook-output progn ((vtptr vtable-pointer)
246 (reason (eql :h))
247 sequencer)
248 (with-slots (class chain-head chain-tail) vtptr
249 (sequence-output (stream sequencer)
250 ((class :ichain chain-head :slots)
251 (format stream " const struct ~A *_vt;~%"
252 (vtable-struct-tag chain-tail chain-head))))))
253
254 (defmethod hook-output progn ((islots islots) reason sequencer)
255 (dolist (slot (islots-slots islots))
256 (hook-output slot reason sequencer)))
257
258 (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
259 (with-slots (class subclass slots) islots
260 (sequence-output (stream sequencer)
261 ((subclass :ichain (sod-class-chain-head class) :slots)
262 (format stream " struct ~A ~A;~%"
263 (islots-struct-tag class)
264 (sod-class-nickname class))))))
265
266 ;;;--------------------------------------------------------------------------
267 ;;; Vtable structure.
268
269 (defmethod hook-output progn ((vtable vtable) reason sequencer)
270 (with-slots (body) vtable
271 (dolist (item body) (hook-output item reason sequencer))))
272
273 (defmethod hook-output progn ((method sod-method)
274 (reason (eql :h))
275 sequencer)
276 (with-slots (class) method
277 (sequence-output (stream sequencer)
278 ((class :methods)
279 (let ((type (sod-method-function-type method)))
280 (princ "extern " stream)
281 (pprint-c-type (commentify-function-type type) stream
282 (sod-method-function-name method))
283 (format stream ";~%"))))))
284
285 (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
286 (with-slots (class chain-head chain-tail) vtable
287 (when (eq class chain-tail)
288 (sequence-output (stream sequencer)
289 :constraint ((class :vtables :start)
290 (class :vtable chain-head :start)
291 (class :vtable chain-head :slots)
292 (class :vtable chain-head :end)
293 (class :vtables :end))
294 ((class :vtable chain-head :start)
295 (format stream "/* Vtable structure. */~@
296 struct ~A {~%"
297 (vtable-struct-tag chain-tail chain-head)))
298 ((class :vtable chain-head :end)
299 (format stream "};~2%")
300 (format stream "/* Union of equivalent superclass vtables. */~@
301 union ~A {~@
302 ~:{ struct ~A ~A;~%~}~
303 };~2%"
304 (vtable-union-tag chain-tail chain-head)
305
306 ;; As for the ichain union, make sure the most specific
307 ;; class is first.
308 (mapcar (lambda (super)
309 (list (vtable-struct-tag super chain-head)
310 (sod-class-nickname super)))
311 (sod-class-chain chain-tail))))))
312 (sequence-output (stream sequencer)
313 ((class :vtable-externs)
314 (format stream "~@<extern const union ~A ~2I~_~A__vtable_~A;~:>~%"
315 (vtable-union-tag chain-tail chain-head)
316 class (sod-class-nickname chain-head))))))
317
318 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
319 (with-slots (class subclass chain-head chain-tail) vtmsgs
320 (sequence-output (stream sequencer)
321 ((subclass :vtable chain-head :slots)
322 (format stream " struct ~A ~A;~%"
323 (vtmsgs-struct-tag subclass class)
324 (sod-class-nickname class))))))
325
326 (defmethod hook-output progn ((vtmsgs vtmsgs)
327 (reason (eql 'vtmsgs))
328 sequencer)
329 (when (vtmsgs-entries vtmsgs)
330 (with-slots (class subclass) vtmsgs
331 (sequence-output (stream sequencer)
332 :constraint ((subclass :vtmsgs :start)
333 (subclass :vtmsgs class :start)
334 (subclass :vtmsgs class :slots)
335 (subclass :vtmsgs class :end)
336 (subclass :vtmsgs :end))
337 ((subclass :vtmsgs class :start)
338 (format stream "/* Messages protocol from class ~A */~@
339 struct ~A {~%"
340 class
341 (vtmsgs-struct-tag subclass class)))
342 ((subclass :vtmsgs class :end)
343 (format stream "};~2%"))))))
344
345 (defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
346 (with-slots (entries) vtmsgs
347 (dolist (entry entries) (hook-output entry reason sequencer))))
348
349 (defmethod hook-output progn ((entry method-entry)
350 (reason (eql 'vtmsgs))
351 sequencer)
352 (let* ((method (method-entry-effective-method entry))
353 (message (effective-method-message method))
354 (class (effective-method-class method))
355 (function-type (method-entry-function-type entry))
356 (commented-type (commentify-function-type function-type))
357 (pointer-type (make-pointer-type commented-type)))
358 (sequence-output (stream sequencer)
359 ((class :vtmsgs (sod-message-class message) :slots)
360 (pprint-logical-block (stream nil :prefix " " :suffix ";")
361 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
362 (terpri stream)))))
363
364 (defmethod hook-output progn ((cptr class-pointer)
365 (reason (eql :h))
366 sequencer)
367 (with-slots (class chain-head metaclass meta-chain-head) cptr
368 (sequence-output (stream sequencer)
369 ((class :vtable chain-head :slots)
370 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
371 metaclass
372 (and (sod-class-direct-superclasses meta-chain-head)
373 (sod-class-nickname meta-chain-head)))))))
374
375 (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
376 (with-slots (class chain-head) boff
377 (sequence-output (stream sequencer)
378 ((class :vtable chain-head :slots)
379 (write-line " size_t _base;" stream)))))
380
381 (defmethod hook-output progn ((choff chain-offset)
382 (reason (eql :h))
383 sequencer)
384 (with-slots (class chain-head target-head) choff
385 (sequence-output (stream sequencer)
386 ((class :vtable chain-head :slots)
387 (format stream " ptrdiff_t _off_~A;~%"
388 (sod-class-nickname target-head))))))
389
390 ;;;--------------------------------------------------------------------------
391 ;;; Implementation output.
392
393 (defvar *instance-class*)
394
395 (defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer)
396 (sequence-output (stream sequencer)
397
398 :constraint
399 ((:classes :start)
400 (class :banner)
401 (class :direct-methods :start) (class :direct-methods :end)
402 (class :effective-methods)
403 (class :vtables :start) (class :vtables :end)
404 (class :object :prepare) (class :object :start) (class :object :end)
405 (:classes :end))
406
407 ((class :banner)
408 (banner (format nil "Class ~A" class) stream))
409
410 ((class :object :start)
411 (format stream "~
412 /* The class object. */
413 const struct ~A ~A__classobj = {~%"
414 (ilayout-struct-tag (sod-class-metaclass class))
415 class))
416 ((class :object :end)
417 (format stream "};~2%")))
418
419 (let ((*instance-class* class))
420 (hook-output (sod-class-ilayout (sod-class-metaclass class))
421 'class
422 sequencer)))
423
424 ;;;--------------------------------------------------------------------------
425 ;;; Direct and effective methods.
426
427 (defmethod hook-output progn ((method delegating-direct-method)
428 (reason (eql :c))
429 sequencer)
430 (with-slots (class body) method
431 (unless body
432 (return-from hook-output))
433 (sequence-output (stream sequencer)
434 ((class :direct-method method :start)
435 (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
436 (mapcar #'argument-name
437 (c-function-arguments (sod-method-next-method-type
438 method)))))
439 ((class :direct-method method :end)
440 (format stream "#undef CALL_NEXT_METHOD~%")))))
441
442 (defmethod hook-output progn ((method sod-method)
443 (reason (eql :c))
444 sequencer)
445 (with-slots (class body) method
446 (unless body
447 (return-from hook-output))
448 (sequence-output (stream sequencer)
449 :constraint ((class :direct-methods :start)
450 (class :direct-method method :start)
451 (class :direct-method method :body)
452 (class :direct-method method :end)
453 (class :direct-methods :end))
454 ((class :direct-method method :body)
455 (pprint-c-type (sod-method-function-type method)
456 stream
457 (sod-method-function-name method))
458 (format stream "~&{~%")
459 (write body :stream stream :pretty nil :escape nil)
460 (format stream "~&}~%"))
461 ((class :direct-method method :end)
462 (terpri stream)))))
463
464 (defmethod hook-output progn ((method basic-effective-method)
465 (reason (eql :c))
466 sequencer)
467 (with-slots (class functions) method
468 (sequence-output (stream sequencer)
469 ((class :effective-methods)
470 (dolist (func functions)
471 (write func :stream stream :escape nil :circle nil))))))
472
473 ;;;--------------------------------------------------------------------------
474 ;;; Vtables.
475
476 (defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer)
477 (with-slots (class chain-head chain-tail) vtable
478 (sequence-output (stream sequencer)
479 :constraint ((class :vtables :start)
480 (class :vtable chain-head :start)
481 (class :vtable chain-head :end)
482 (class :vtables :end))
483 ((class :vtable chain-head :start)
484 (format stream "/* Vtable for ~A chain. */~@
485 const union ~A ~A = { {~%"
486 chain-head
487 (vtable-union-tag chain-tail chain-head)
488 (vtable-name class chain-head)))
489 ((class :vtable chain-head :end)
490 (format stream "} };~2%")))))
491
492 (defmethod hook-output progn ((cptr class-pointer)
493 (reason (eql :c))
494 sequencer)
495 (with-slots (class chain-head metaclass meta-chain-head) cptr
496 (sequence-output (stream sequencer)
497 :constraint ((class :vtable chain-head :start)
498 (class :vtable chain-head :class-pointer metaclass)
499 (class :vtable chain-head :end))
500 ((class :vtable chain-head :class-pointer metaclass)
501 (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%"
502 (if (sod-class-direct-superclasses meta-chain-head)
503 (format nil "_cls_~A"
504 (sod-class-nickname meta-chain-head))
505 "_class")
506 class
507 (sod-class-nickname meta-chain-head)
508 (sod-class-nickname metaclass))))))
509
510 (defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer)
511 (with-slots (class chain-head) boff
512 (sequence-output (stream sequencer)
513 :constraint ((class :vtable chain-head :start)
514 (class :vtable chain-head :base-offset)
515 (class :vtable chain-head :end))
516 ((class :vtable chain-head :base-offset)
517 (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%"
518 "_base"
519 (ilayout-struct-tag class)
520 (sod-class-nickname chain-head))))))
521
522 (defmethod hook-output progn ((choff chain-offset)
523 (reason (eql :c))
524 sequencer)
525 (with-slots (class chain-head target-head) choff
526 (sequence-output (stream sequencer)
527 :constraint ((class :vtable chain-head :start)
528 (class :vtable chain-head :chain-offset target-head)
529 (class :vtable chain-head :end))
530 ((class :vtable chain-head :chain-offset target-head)
531 (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
532 (format nil "_off_~A" (sod-class-nickname target-head))
533 (ilayout-struct-tag class)
534 (sod-class-nickname chain-head)
535 (sod-class-nickname target-head))))))
536
537 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
538 (with-slots (class subclass chain-head) vtmsgs
539 (sequence-output (stream sequencer)
540 :constraint ((subclass :vtable chain-head :start)
541 (subclass :vtable chain-head :vtmsgs class :start)
542 (subclass :vtable chain-head :vtmsgs class :slots)
543 (subclass :vtable chain-head :vtmsgs class :end)
544 (subclass :vtable chain-head :end))
545 ((subclass :vtable chain-head :vtmsgs class :start)
546 (format stream " { /* Method entries for ~A messages. */~%"
547 class))
548 ((subclass :vtable chain-head :vtmsgs class :end)
549 (format stream " },~%")))))
550
551 (defmethod hook-output progn ((entry method-entry)
552 (reason (eql :c))
553 sequencer)
554 (with-slots (method chain-head chain-tail role) entry
555 (let* ((message (effective-method-message method))
556 (class (effective-method-class method))
557 (super (sod-message-class message)))
558 (sequence-output (stream sequencer)
559 ((class :vtable chain-head :vtmsgs super :slots)
560 (format stream " /* ~19@A = */ ~A,~%"
561 (method-entry-slot-name entry)
562 (method-entry-function-name method chain-head role)))))))
563
564 ;;;--------------------------------------------------------------------------
565 ;;; Filling in the class object.
566
567 (defmethod hook-output progn ((ichain ichain)
568 (reason (eql 'class))
569 sequencer)
570 (with-slots (class chain-head) ichain
571 (sequence-output (stream sequencer)
572 :constraint ((*instance-class* :object :start)
573 (*instance-class* :object chain-head :ichain :start)
574 (*instance-class* :object chain-head :ichain :end)
575 (*instance-class* :object :end))
576 ((*instance-class* :object chain-head :ichain :start)
577 (format stream " { { /* ~A ichain */~%"
578 (sod-class-nickname chain-head)))
579 ((*instance-class* :object chain-head :ichain :end)
580 (format stream " } },~%")))))
581
582 (defmethod hook-output progn ((islots islots)
583 (reason (eql 'class))
584 sequencer)
585 (with-slots (class) islots
586 (let ((chain-head (sod-class-chain-head class)))
587 (sequence-output (stream sequencer)
588 :constraint ((*instance-class* :object chain-head :ichain :start)
589 (*instance-class* :object class :slots :start)
590 (*instance-class* :object class :slots)
591 (*instance-class* :object class :slots :end)
592 (*instance-class* :object chain-head :ichain :end))
593 ((*instance-class* :object class :slots :start)
594 (format stream " { /* Class ~A */~%" class))
595 ((*instance-class* :object class :slots :end)
596 (format stream " },~%"))))))
597
598 (defmethod hook-output progn ((vtptr vtable-pointer)
599 (reason (eql 'class))
600 sequencer)
601 (with-slots (class chain-head chain-tail) vtptr
602 (sequence-output (stream sequencer)
603 :constraint ((*instance-class* :object chain-head :ichain :start)
604 (*instance-class* :object chain-head :vtable)
605 (*instance-class* :object chain-head :ichain :end))
606 ((*instance-class* :object chain-head :vtable)
607 (format stream " /* ~17@A = */ &~A.~A,~%"
608 "_vt"
609 (vtable-name class chain-head)
610 (sod-class-nickname chain-tail))))))
611
612 (defgeneric find-class-initializer (slot class)
613 (:method ((slot effective-slot) (class sod-class))
614 (let ((dslot (effective-slot-direct-slot slot)))
615 (or (some (lambda (super)
616 (find dslot (sod-class-class-initializers super)
617 :test #'sod-initializer-slot))
618 (sod-class-precedence-list class))
619 (effective-slot-initializer slot)))))
620
621 (defgeneric output-class-initializer (slot instance stream)
622 (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
623 (let ((func (effective-slot-initializer-function slot))
624 (direct-slot (effective-slot-direct-slot slot)))
625 (if func
626 (format stream " /* ~15@A = */ ~A,~%"
627 (sod-slot-name direct-slot)
628 (funcall func instance))
629 (call-next-method))))
630 (:method ((slot effective-slot) (instance sod-class) stream)
631 (let ((init (find-class-initializer slot instance))
632 (direct-slot (effective-slot-direct-slot slot)))
633 (ecase (sod-initializer-value-kind init)
634 (:simple (format stream " /* ~15@A = */ ~A,~%"
635 (sod-slot-name direct-slot)
636 (sod-initializer-value-form init)))
637 (:compound (format stream " /* ~15@A = */ ~@<{ ~;~A~; },~:>~%"
638 (sod-slot-name direct-slot)
639 (sod-initializer-value-form init)))))))
640
641 (defmethod hook-output progn ((slot sod-class-effective-slot)
642 (reason (eql 'class))
643 sequencer)
644 (let ((instance *instance-class*)
645 (func (effective-slot-prepare-function slot)))
646 (when func
647 (sequence-output (stream sequencer)
648 ((instance :object :prepare)
649 (funcall func instance stream))))))
650
651 (defmethod hook-output progn ((slot effective-slot)
652 (reason (eql 'class))
653 sequencer)
654 (with-slots (class (dslot slot)) slot
655 (let ((instance *instance-class*)
656 (super (sod-slot-class dslot)))
657 (sequence-output (stream sequencer)
658 ((instance :object super :slots)
659 (output-class-initializer slot instance stream))))))
660
661 ;;;----- That's all, folks --------------------------------------------------
Simple Object Design: an object system for C