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 ;;;--------------------------------------------------------------------------
29 ;;; Walking the layout tree.
31 (defmethod hook-output progn ((class sod-class) reason sequencer)
32 (with-slots ((ilayout %ilayout) vtables methods effective-methods) class
33 (hook-output ilayout reason sequencer)
34 (dolist (method methods) (hook-output method reason sequencer))
35 (dolist (method effective-methods) (hook-output method reason sequencer))
36 (dolist (vtable vtables) (hook-output vtable reason sequencer))))
38 (defmethod hook-output progn ((ilayout ilayout) reason sequencer)
39 (with-slots (ichains) ilayout
40 (dolist (ichain ichains) (hook-output ichain reason sequencer))))
42 (defmethod hook-output progn ((ichain ichain) reason sequencer)
43 (dolist (item (ichain-body ichain)) (hook-output item reason sequencer)))
45 (defmethod hook-output progn ((islots islots) reason sequencer)
46 (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer)))
48 (defmethod hook-output progn ((vtable vtable) reason sequencer)
49 (with-slots (body) vtable
50 (dolist (item body) (hook-output item reason sequencer))))
52 (defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
53 (with-slots (entries) vtmsgs
54 (dolist (entry entries) (hook-output entry reason sequencer))))
56 ;;;--------------------------------------------------------------------------
59 (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
61 ;; Main output sequencing.
62 (sequence-output (stream sequencer)
67 (class :islots :start) (class :islots :slots) (class :islots :end)
68 (class :vtmsgs :start) (class :vtmsgs :end)
69 (class :vtables :start) (class :vtables :end)
70 (class :vtable-externs) (class :vtable-externs-after)
71 (class :methods :start) (class :methods) (class :methods :end)
72 (class :ichains :start) (class :ichains :end)
73 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
75 (class :message-macros)
80 (format stream "typedef struct ~A ~A;~%"
81 (ichain-struct-tag class (sod-class-chain-head class)) class))
84 (banner (format nil "Class ~A" class) stream))
85 ((class :vtable-externs-after)
88 ((class :vtable-externs)
89 (format stream "/* Vtable structures. */~%"))
92 (let ((metaclass (sod-class-metaclass class))
93 (metaroot (find-root-metaclass class)))
94 (format stream "/* The class object. */~@
95 extern const struct ~A ~A__classobj;~@
96 #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
97 (ilayout-struct-tag metaclass) class
98 (sod-class-nickname (sod-class-chain-head metaroot))
99 (sod-class-nickname metaroot)))))
101 ;; Maybe generate an islots structure.
102 (when (sod-class-slots class)
103 (dolist (slot (sod-class-slots class))
104 (hook-output slot 'islots sequencer))
105 (sequence-output (stream sequencer)
106 ((class :islots :start)
107 (format stream "/* Instance slots. */~@
109 (islots-struct-tag class)))
110 ((class :islots :end)
111 (format stream "};~2%"))))
113 ;; Declare the direct methods.
114 (when (sod-class-methods class)
115 (sequence-output (stream sequencer)
116 ((class :methods :start)
117 (format stream "/* Direct methods. */~%"))
118 ((class :methods :end)
121 ;; Provide upcast macros which do the right thing.
122 (when (sod-class-direct-superclasses class)
123 (sequence-output (stream sequencer)
124 ((class :conversions)
125 (let ((chain-head (sod-class-chain-head class)))
126 (format stream "/* Conversion macros. */~%")
127 (dolist (super (cdr (sod-class-precedence-list class)))
128 (let ((super-head (sod-class-chain-head super)))
129 (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
130 ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
131 class (sod-class-nickname super) super
132 (eq chain-head super-head)
133 (sod-class-nickname super-head))))
136 ;; Provide convenience macros for sending the newly defined messages. (The
137 ;; macros work on all subclasses too.)
139 ;; We need each message's method entry type for this, so we need to dig it
140 ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
141 ;; entries for precisely the messages we want to make macros for.
142 (when (some #'varargs-message-p (sod-class-messages class))
143 (one-off-output 'varargs-macros sequencer :early-decls
146 "~%SOD__VARARGS_MACROS_PREAMBLE~%"))))
147 (when (sod-class-messages class)
148 (sequence-output (stream sequencer)
149 ((class :message-macros)
150 (let* ((vtable (find (sod-class-chain-head class)
151 (sod-class-vtables class)
152 :key #'vtable-chain-head))
153 (vtmsgs (find-if (lambda (item)
154 (and (typep item 'vtmsgs)
155 (eql (vtmsgs-class item) class)))
156 (vtable-body vtable))))
157 (format stream "/* Message invocation macros. */~%")
158 (dolist (entry (vtmsgs-entries vtmsgs))
159 (let* ((type (method-entry-function-type entry))
160 (args (c-function-arguments type))
161 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
162 (do ((args args (cdr args)))
164 (let* ((raw-name (princ-to-string (argument-name (car args))))
165 (name (if (find raw-name
167 (sod-class-nickname class)
168 (method-entry-slot-name entry))
170 (format nil "sod__a_~A" raw-name)
172 (cond ((and (cdr args) (eq (cadr args) :ellipsis))
174 (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
175 (push (format nil "/*~A*/ ..." name) in-names)
176 (push "__VA_ARGS__" out-names)
180 (push name out-names)))))
182 (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
183 (format stream "#define ~A(~{~A~^, ~}) ~
184 ~A->_vt->~A.~A(~{~A~^, ~})~%"
185 (message-macro-name class entry)
188 (sod-class-nickname class)
189 (method-entry-slot-name entry)
190 (nreverse out-names))
192 (format stream "#endif~%"))))
195 ;; Generate vtmsgs structure for all superclasses.
196 (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer))
198 ;;;--------------------------------------------------------------------------
199 ;;; Instance structure.
201 (defmethod hook-output progn
202 ((slot sod-slot) (reason (eql 'islots)) sequencer)
203 (sequence-output (stream sequencer)
204 (((sod-slot-class slot) :islots :slots)
205 (pprint-logical-block (stream nil :prefix " " :suffix ";")
206 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
209 (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer)
210 (with-slots ((class %class) ichains) ilayout
211 (sequence-output (stream sequencer)
212 ((class :ilayout :start)
213 (format stream "/* Instance layout. */~@
215 (ilayout-struct-tag class)))
216 ((class :ilayout :end)
217 (format stream "};~2%")))
218 (dolist (ichain ichains)
219 (hook-output ichain 'ilayout sequencer))))
221 (defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer)
222 (with-slots ((class %class) chain-head chain-tail) ichain
223 (when (eq class chain-tail)
224 (sequence-output (stream sequencer)
225 :constraint ((class :ichains :start)
226 (class :ichain chain-head :start)
227 (class :ichain chain-head :slots)
228 (class :ichain chain-head :end)
229 (class :ichains :end))
230 ((class :ichain chain-head :start)
231 (format stream "/* Instance chain structure. */~@
233 (ichain-struct-tag chain-tail chain-head)))
234 ((class :ichain chain-head :end)
235 (format stream "};~2%")
236 (format stream "/* Union of equivalent superclass chains. */~@
238 ~:{ struct ~A ~A;~%~}~
240 (ichain-union-tag chain-tail chain-head)
242 ;; Make sure the most specific class is first: only the
243 ;; first element of a union can be statically initialized in
245 (mapcar (lambda (super)
246 (list (ichain-struct-tag super chain-head)
247 (sod-class-nickname super)))
248 (sod-class-chain chain-tail))))))))
250 (defmethod hook-output progn
251 ((ichain ichain) (reason (eql 'ilayout)) sequencer)
252 (with-slots ((class %class) chain-head chain-tail) ichain
253 (sequence-output (stream sequencer)
254 ((class :ilayout :slots)
255 (format stream " union ~A ~A;~%"
256 (ichain-union-tag chain-tail chain-head)
257 (sod-class-nickname chain-head))))))
259 (defmethod hook-output progn ((vtptr vtable-pointer)
262 (with-slots ((class %class) chain-head chain-tail) vtptr
263 (when (eq class chain-tail)
264 (sequence-output (stream sequencer)
265 ((class :ichain chain-head :slots)
266 (format stream " const struct ~A *_vt;~%"
267 (vtable-struct-tag chain-tail chain-head)))))))
269 (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
270 (with-slots ((class %class) subclass slots) islots
271 (let ((head (sod-class-chain-head class)))
272 (when (eq head (sod-class-chain-head subclass))
273 (sequence-output (stream sequencer)
274 ((subclass :ichain (sod-class-chain-head class) :slots)
275 (format stream " struct ~A ~A;~%"
276 (islots-struct-tag class)
277 (sod-class-nickname class))))))))
279 ;;;--------------------------------------------------------------------------
280 ;;; Vtable structure.
282 (defmethod hook-output progn
283 ((method sod-method) (reason (eql :h)) sequencer)
284 (with-slots ((class %class)) method
285 (sequence-output (stream sequencer)
287 (let ((type (sod-method-function-type method)))
288 (princ "extern " stream)
289 (pprint-c-type (commentify-function-type type) stream
290 (sod-method-function-name method))
291 (format stream ";~%"))))))
293 (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
294 (with-slots ((class %class) chain-head chain-tail) vtable
295 (when (eq class chain-tail)
296 (sequence-output (stream sequencer)
297 :constraint ((class :vtables :start)
298 (class :vtable chain-head :start)
299 (class :vtable chain-head :slots)
300 (class :vtable chain-head :end)
301 (class :vtables :end))
302 ((class :vtable chain-head :start)
303 (format stream "/* Vtable structure. */~@
305 (vtable-struct-tag chain-tail chain-head)))
306 ((class :vtable chain-head :end)
307 (format stream "};~2%")
308 (format stream "/* Union of equivalent superclass vtables. */~@
310 ~:{ struct ~A ~A;~%~}~
312 (vtable-union-tag chain-tail chain-head)
314 ;; As for the ichain union, make sure the most specific
316 (mapcar (lambda (super)
317 (list (vtable-struct-tag super chain-head)
318 (sod-class-nickname super)))
319 (sod-class-chain chain-tail))))))
320 (sequence-output (stream sequencer)
321 ((class :vtable-externs)
322 (format stream "~@<extern const union ~A ~2I~_~A;~:>~%"
323 (vtable-union-tag chain-tail chain-head)
324 (vtable-name class chain-head))))))
326 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
327 (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
328 (when (eq subclass chain-tail)
329 (sequence-output (stream sequencer)
330 ((subclass :vtable chain-head :slots)
331 (format stream " struct ~A ~A;~%"
332 (vtmsgs-struct-tag subclass class)
333 (sod-class-nickname class)))))))
335 (defmethod hook-output progn
336 ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
337 (when (vtmsgs-entries vtmsgs)
338 (with-slots ((class %class) subclass) vtmsgs
339 (sequence-output (stream sequencer)
340 :constraint ((subclass :vtmsgs :start)
341 (subclass :vtmsgs class :start)
342 (subclass :vtmsgs class :slots)
343 (subclass :vtmsgs class :end)
344 (subclass :vtmsgs :end))
345 ((subclass :vtmsgs class :start)
346 (format stream "/* Messages protocol from class ~A */~@
349 (vtmsgs-struct-tag subclass class)))
350 ((subclass :vtmsgs class :end)
351 (format stream "};~2%"))))))
353 (defmethod hook-output progn
354 ((entry method-entry) (reason (eql 'vtmsgs)) sequencer)
355 (let* ((method (method-entry-effective-method entry))
356 (message (effective-method-message method))
357 (class (effective-method-class method))
358 (function-type (method-entry-function-type entry))
359 (commented-type (commentify-function-type function-type))
360 (pointer-type (make-pointer-type commented-type)))
361 (sequence-output (stream sequencer)
362 ((class :vtmsgs (sod-message-class message) :slots)
363 (pprint-logical-block (stream nil :prefix " " :suffix ";")
364 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
367 (defmethod hook-output progn
368 ((cptr class-pointer) (reason (eql :h)) sequencer)
369 (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
370 (when (eq chain-head (sod-class-chain-head class))
371 (sequence-output (stream sequencer)
372 ((class :vtable chain-head :slots)
373 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
375 (and (sod-class-direct-superclasses meta-chain-head)
376 (sod-class-nickname meta-chain-head))))))))
378 (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
379 (with-slots ((class %class) chain-head) boff
380 (when (eq chain-head (sod-class-chain-head class))
381 (sequence-output (stream sequencer)
382 ((class :vtable chain-head :slots)
383 (write-line " size_t _base;" stream))))))
385 (defmethod hook-output progn
386 ((choff chain-offset) (reason (eql :h)) sequencer)
387 (with-slots ((class %class) chain-head target-head) choff
388 (when (eq chain-head (sod-class-chain-head class))
389 (sequence-output (stream sequencer)
390 ((class :vtable chain-head :slots)
391 (format stream " ptrdiff_t _off_~A;~%"
392 (sod-class-nickname target-head)))))))
394 ;;;--------------------------------------------------------------------------
395 ;;; Implementation output.
397 (export '*instance-class*)
398 (defvar *instance-class* nil
399 "The class currently being output.
401 This is bound during the `hook-output' traversal of a class layout for
402 `:c' output, since some of the objects traversed actually `belong' to
403 superclasses and there's no other way to find out what the reference class
406 It may be bound at other times.")
408 (defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer)
409 (sequence-output (stream sequencer)
414 (class :direct-methods :start) (class :direct-methods :end)
415 (class :effective-methods)
416 (class :vtables :start) (class :vtables :end)
417 (class :object :prepare) (class :object :start) (class :object :end)
421 (banner (format nil "Class ~A" class) stream))
423 ((class :object :start)
425 /* The class object. */
426 const struct ~A ~A__classobj = {~%"
427 (ilayout-struct-tag (sod-class-metaclass class))
429 ((class :object :end)
430 (format stream "};~2%")))
432 (let ((*instance-class* class))
433 (hook-output (sod-class-ilayout (sod-class-metaclass class))
436 ;;;--------------------------------------------------------------------------
437 ;;; Direct and effective methods.
439 (defmethod hook-output progn
440 ((method delegating-direct-method) (reason (eql :c)) sequencer)
441 (with-slots ((class %class) body) method
443 (return-from hook-output))
444 (sequence-output (stream sequencer)
445 ((class :direct-method method :start)
446 (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
447 (mapcar #'argument-name
448 (c-function-arguments (sod-method-next-method-type
450 ((class :direct-method method :end)
451 (format stream "#undef CALL_NEXT_METHOD~%")))))
453 (defmethod hook-output progn
454 ((method sod-method) (reason (eql :c)) sequencer)
455 (with-slots ((class %class) role body message) method
457 (return-from hook-output))
458 (sequence-output (stream sequencer)
459 :constraint ((class :direct-methods :start)
460 (class :direct-method method :banner)
461 (class :direct-method method :start)
462 (class :direct-method method :body)
463 (class :direct-method method :end)
464 (class :direct-methods :end))
465 ((class :direct-method method :banner)
466 (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
467 on `~A.~A' ~:_defined by `~A'."
470 (sod-message-class message))
471 (sod-message-name message)
474 ((class :direct-method method :body)
475 (pprint-c-type (sod-method-function-type method)
477 (sod-method-function-name method))
478 (format stream "~&{~%")
479 (write body :stream stream :pretty nil :escape nil)
480 (format stream "~&}~%"))
481 ((class :direct-method method :end)
484 (defmethod hook-output progn
485 ((method basic-effective-method) (reason (eql :c)) sequencer)
486 (with-slots ((class %class) functions) method
487 (sequence-output (stream sequencer)
488 ((class :effective-methods)
489 (dolist (func functions)
490 (write func :stream stream :escape nil :circle nil))))))
492 ;;;--------------------------------------------------------------------------
495 (defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer)
496 (with-slots ((class %class) chain-head chain-tail) vtable
497 (sequence-output (stream sequencer)
498 :constraint ((class :vtables :start)
499 (class :vtable chain-head :start)
500 (class :vtable chain-head :end)
501 (class :vtables :end))
502 ((class :vtable chain-head :start)
503 (format stream "/* Vtable for ~A chain. */~@
504 const union ~A ~A = { {~%"
506 (vtable-union-tag chain-tail chain-head)
507 (vtable-name class chain-head)))
508 ((class :vtable chain-head :end)
509 (format stream "} };~2%")))))
511 (defmethod hook-output progn
512 ((cptr class-pointer) (reason (eql :c)) sequencer)
513 (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
514 (sequence-output (stream sequencer)
515 :constraint ((class :vtable chain-head :start)
516 (class :vtable chain-head :class-pointer metaclass)
517 (class :vtable chain-head :end))
518 ((class :vtable chain-head :class-pointer metaclass)
519 (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%"
520 (if (sod-class-direct-superclasses meta-chain-head)
521 (format nil "_cls_~A"
522 (sod-class-nickname meta-chain-head))
525 (sod-class-nickname meta-chain-head)
526 (sod-class-nickname metaclass))))))
528 (defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer)
529 (with-slots ((class %class) chain-head) boff
530 (sequence-output (stream sequencer)
531 :constraint ((class :vtable chain-head :start)
532 (class :vtable chain-head :base-offset)
533 (class :vtable chain-head :end))
534 ((class :vtable chain-head :base-offset)
535 (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%"
537 (ilayout-struct-tag class)
538 (sod-class-nickname chain-head))))))
540 (defmethod hook-output progn
541 ((choff chain-offset) (reason (eql :c)) sequencer)
542 (with-slots ((class %class) chain-head target-head) choff
543 (sequence-output (stream sequencer)
544 :constraint ((class :vtable chain-head :start)
545 (class :vtable chain-head :chain-offset target-head)
546 (class :vtable chain-head :end))
547 ((class :vtable chain-head :chain-offset target-head)
548 (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
549 (format nil "_off_~A" (sod-class-nickname target-head))
550 (ilayout-struct-tag class)
551 (sod-class-nickname chain-head)
552 (sod-class-nickname target-head))))))
554 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
555 (with-slots ((class %class) subclass chain-head) vtmsgs
556 (sequence-output (stream sequencer)
557 :constraint ((subclass :vtable chain-head :start)
558 (subclass :vtable chain-head :vtmsgs class :start)
559 (subclass :vtable chain-head :vtmsgs class :slots)
560 (subclass :vtable chain-head :vtmsgs class :end)
561 (subclass :vtable chain-head :end))
562 ((subclass :vtable chain-head :vtmsgs class :start)
563 (format stream " { /* Method entries for ~A messages. */~%"
565 ((subclass :vtable chain-head :vtmsgs class :end)
566 (format stream " },~%")))))
568 (defmethod hook-output progn
569 ((entry method-entry) (reason (eql :c)) sequencer)
570 (with-slots ((method %method) chain-head chain-tail role) entry
571 (let* ((message (effective-method-message method))
572 (class (effective-method-class method))
573 (super (sod-message-class message)))
574 (sequence-output (stream sequencer)
575 ((class :vtable chain-head :vtmsgs super :slots)
576 (format stream " /* ~19@A = */ ~A,~%"
577 (method-entry-slot-name entry)
578 (method-entry-function-name method chain-head role)))))))
580 ;;;--------------------------------------------------------------------------
581 ;;; Filling in the class object.
583 (defmethod hook-output progn
584 ((ichain ichain) (reason (eql 'class)) sequencer)
585 (with-slots ((class %class) chain-head) ichain
586 (sequence-output (stream sequencer)
587 :constraint ((*instance-class* :object :start)
588 (*instance-class* :object chain-head :ichain :start)
589 (*instance-class* :object chain-head :ichain :end)
590 (*instance-class* :object :end))
591 ((*instance-class* :object chain-head :ichain :start)
592 (format stream " { { /* ~A ichain */~%"
593 (sod-class-nickname chain-head)))
594 ((*instance-class* :object chain-head :ichain :end)
595 (format stream " } },~%")))))
597 (defmethod hook-output progn
598 ((islots islots) (reason (eql 'class)) sequencer)
599 (with-slots ((class %class)) islots
600 (let ((chain-head (sod-class-chain-head class)))
601 (sequence-output (stream sequencer)
602 :constraint ((*instance-class* :object chain-head :ichain :start)
603 (*instance-class* :object class :slots :start)
604 (*instance-class* :object class :slots)
605 (*instance-class* :object class :slots :end)
606 (*instance-class* :object chain-head :ichain :end))
607 ((*instance-class* :object class :slots :start)
608 (format stream " { /* Class ~A */~%" class))
609 ((*instance-class* :object class :slots :end)
610 (format stream " },~%"))))))
612 (defmethod hook-output progn
613 ((vtptr vtable-pointer) (reason (eql 'class)) sequencer)
614 (with-slots ((class %class) chain-head chain-tail) vtptr
615 (sequence-output (stream sequencer)
616 :constraint ((*instance-class* :object chain-head :ichain :start)
617 (*instance-class* :object chain-head :vtable)
618 (*instance-class* :object chain-head :ichain :end))
619 ((*instance-class* :object chain-head :vtable)
620 (format stream " /* ~17@A = */ &~A.~A,~%"
622 (vtable-name class chain-head)
623 (sod-class-nickname chain-tail))))))
625 (defgeneric find-class-initializer (slot class)
626 (:method ((slot effective-slot) (class sod-class))
627 (let ((dslot (effective-slot-direct-slot slot)))
628 (or (some (lambda (super)
629 (find dslot (sod-class-class-initializers super)
630 :test #'sod-initializer-slot))
631 (sod-class-precedence-list class))
632 (effective-slot-initializer slot)))))
634 (defgeneric output-class-initializer (slot instance stream)
635 (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
636 (let ((func (effective-slot-initializer-function slot))
637 (direct-slot (effective-slot-direct-slot slot)))
639 (format stream " /* ~15@A = */ ~A,~%"
640 (sod-slot-name direct-slot)
641 (funcall func instance))
642 (call-next-method))))
643 (:method ((slot effective-slot) (instance sod-class) stream)
644 (let ((init (find-class-initializer slot instance))
645 (direct-slot (effective-slot-direct-slot slot)))
646 (ecase (sod-initializer-value-kind init)
647 (:simple (format stream " /* ~15@A = */ ~A,~%"
648 (sod-slot-name direct-slot)
649 (sod-initializer-value-form init)))
650 (:compound (format stream " /* ~15@A = */ ~@<{ ~;~A~; },~:>~%"
651 (sod-slot-name direct-slot)
652 (sod-initializer-value-form init)))))))
654 (defmethod hook-output progn
655 ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer)
656 (let ((instance *instance-class*)
657 (func (effective-slot-prepare-function slot)))
659 (sequence-output (stream sequencer)
660 ((instance :object :prepare)
661 (funcall func instance stream))))))
663 (defmethod hook-output progn
664 ((slot effective-slot) (reason (eql 'class)) sequencer)
665 (with-slots ((class %class) (dslot slot)) slot
666 (let ((instance *instance-class*)
667 (super (sod-slot-class dslot)))
668 (sequence-output (stream sequencer)
669 ((instance :object super :slots)
670 (output-class-initializer slot instance stream))))))
672 ;;;----- That's all, folks --------------------------------------------------