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 :after ((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 :after ((ilayout ilayout) reason sequencer)
39 (with-slots (ichains) ilayout
40 (dolist (ichain ichains) (hook-output ichain reason sequencer))))
42 (defmethod hook-output :after ((ichain ichain) reason sequencer)
43 (dolist (item (ichain-body ichain)) (hook-output item reason sequencer)))
45 (defmethod hook-output :after ((islots islots) reason sequencer)
46 (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer)))
48 (defmethod hook-output :after ((vtable vtable) reason sequencer)
49 (with-slots (body) vtable
50 (dolist (item body) (hook-output item reason sequencer))))
52 (defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer)
53 (with-slots (entries) vtmsgs
54 (dolist (entry entries) (hook-output entry reason sequencer))))
56 ;;;--------------------------------------------------------------------------
57 ;;; Class declarations.
59 (export 'emit-class-typedef)
60 (defgeneric emit-class-typedef (class stream)
62 "Emit a `typedef' for the CLASS's C class type to the output STREAM.
64 By default, this will be an alias for the class's home `ichain'
66 (defmethod emit-class-typedef ((class sod-class) stream)
67 (format stream "typedef struct ~A ~A;~%"
68 (ichain-struct-tag class (sod-class-chain-head class)) class))
70 (export 'emit-class-object-decl)
71 (defgeneric emit-class-object-decl (class stream)
73 "Emit the declaration and macros for the CLASS's class object.
75 This includes the main declaration, and the convenience macros for
76 referring to the class object's individual chains. Write everything to
78 (defmethod emit-class-object-decl ((class sod-class) stream)
79 (let ((metaclass (sod-class-metaclass class))
80 (metaroot (find-root-metaclass class)))
82 ;; Output the actual class object declaration, and the special
83 ;; `...__class' macro for the root-metaclass chain.
84 (format stream "/* The class object. */~@
85 extern const struct ~A ~A__classobj;~@
86 #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%"
87 (ilayout-struct-tag metaclass) class
88 (sod-class-nickname (sod-class-chain-head metaroot))
89 (sod-class-nickname metaroot))
91 ;; Write the uglier `...__cls_...' macros for the class object's other
93 (dolist (chain (sod-class-chains metaclass))
94 (let ((tail (car chain)))
95 (unless (eq tail metaroot)
96 (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%"
97 class (sod-class-nickname (sod-class-chain-head tail))
98 (sod-class-nickname tail)))))
101 (export 'emit-class-conversion-macro)
102 (defgeneric emit-class-conversion-macro (class super stream)
104 "Emit a macro for converting an instance of CLASS to an instance of SUPER.
106 By default this is named `CLASS__CONV_SPR'. In-chain upcasts are just a
107 trivial pointer cast, which any decent compiler will elide; cross-chain
108 upcasts use the `SOD_XCHAIN' macro. Write the macro to the output
110 (defmethod emit-class-conversion-macro
111 ((class sod-class) (super sod-class) stream)
112 (let ((super-head (sod-class-chain-head super)))
113 (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
114 ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
115 class (sod-class-nickname super) super
116 (eq super-head (sod-class-chain-head class))
117 (sod-class-nickname super-head))))
119 (export 'emit-message-macro-defn)
120 (defgeneric emit-message-macro-defn
121 (class entry varargsp me in-names out-names stream)
123 "Output a message macro for invoking a method ENTRY, with given arguments.
125 The default method on `emit-message-macro' calcualates the necessary
126 argument lists and calls this function to actually write the necessary
127 `#define' line to the stream. The intended division of responsibilities
128 is that `emit-message-macro' handles the peculiarities of marshalling the
129 arguments to the method entry function, while `emit-message-macro-defn'
130 concerns itself with navigating the vtable to find the right function in
132 (:method :around ((class sod-class) (entry method-entry)
133 varargsp me in-names out-names
135 (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
137 (when varargsp (format stream "#endif~%"))))
138 (defmethod emit-message-macro-defn ((class sod-class) (entry method-entry)
139 varargsp me in-names out-names
141 (format stream "#define ~A(~{~A~^, ~}) (~A)->_vt->~A.~A(~{~A~^, ~})~%"
142 (message-macro-name class entry)
145 (sod-class-nickname class)
146 (method-entry-slot-name entry)
149 (export 'emit-message-macro)
150 (defgeneric emit-message-macro (class entry stream)
152 "Write a macro for invoking the method ENTRY on an instance of CLASS.
154 The default behaviour is quite complicated, particular when varargs or
155 keyword messages are involved."))
156 (defmethod emit-message-macro ((class sod-class) (entry method-entry) stream)
157 (when (some (lambda (message)
158 (or (keyword-message-p message)
159 (varargs-message-p message)))
160 (sod-class-messages class)))
161 (let* ((type (method-entry-function-type entry))
162 (args (c-function-arguments type))
163 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
164 (do ((args args (cdr args)))
166 (let* ((raw-name (princ-to-string (argument-name (car args))))
167 (name (if (find raw-name
169 (sod-class-nickname class)
170 (method-entry-slot-name entry))
172 (format nil "sod__a_~A" raw-name)
174 (cond ((and (cdr args) (eq (cadr args) :ellipsis))
176 (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
177 (push (format nil "/*~A*/ ..." name) in-names)
178 (push "__VA_ARGS__" out-names)
182 (push name out-names)))))
183 (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
184 (emit-message-macro-defn class entry varargsp me
188 (when varargsp (format stream "#endif~%"))))
190 (defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer)
192 ;; Main output sequencing.
193 (sequence-output (stream sequencer)
198 (class :islots :start) (class :islots :slots) (class :islots :end)
199 (class :vtmsgs :start) (class :vtmsgs :end)
200 (class :vtables :start) (class :vtables :end)
201 (class :vtable-externs) (class :vtable-externs-after)
202 (class :methods :start) (class :methods :defs)
203 (class :methods) (class :methods :end)
204 (class :ichains :start) (class :ichains :end)
205 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
207 (class :message-macros)
211 (:typedefs (emit-class-typedef class stream))
212 ((class :banner) (banner (format nil "Class ~A" class) stream))
213 ((class :vtable-externs-after) (terpri stream))
214 ((class :vtable-externs) (format stream "/* Vtable structures. */~%"))
215 ((class :object) (emit-class-object-decl class stream)))
217 ;; Maybe generate an islots structure.
218 (when (sod-class-slots class)
219 (sequence-output (stream sequencer)
220 ((class :islots :start)
221 (format stream "/* Instance slots. */~@
223 (islots-struct-tag class)))
224 ((class :islots :end)
225 (format stream "};~2%"))))
227 ;; Declare the direct methods.
228 (when (sod-class-methods class)
229 (sequence-output (stream sequencer)
230 ((class :methods :start)
231 (format stream "/* Direct methods. */~%"))
232 ((class :methods :end)
235 ;; Provide upcast macros which do the right thing.
236 (when (sod-class-direct-superclasses class)
237 (sequence-output (stream sequencer)
238 ((class :conversions)
239 (format stream "/* Conversion macros. */~%")
240 (dolist (super (cdr (sod-class-precedence-list class)))
241 (emit-class-conversion-macro class super stream))
244 ;; Provide convenience macros for sending the newly defined messages. (The
245 ;; macros work on all subclasses too.)
247 ;; We need each message's method entry type for this, so we need to dig it
248 ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
249 ;; entries for precisely the messages we want to make macros for.
250 (when (some (lambda (message)
251 (or (keyword-message-p message)
252 (varargs-message-p message)))
253 (sod-class-messages class))
254 (one-off-output 'varargs-macros sequencer :early-decls
257 "~%SOD__VARARGS_MACROS_PREAMBLE~%"))))
258 (when (sod-class-messages class)
259 (sequence-output (stream sequencer)
260 ((class :message-macros)
261 (let* ((vtable (find (sod-class-chain-head class)
262 (sod-class-vtables class)
263 :key #'vtable-chain-head))
264 (vtmsgs (find-if (lambda (item)
265 (and (typep item 'vtmsgs)
266 (eql (vtmsgs-class item) class)))
267 (vtable-body vtable))))
268 (format stream "/* Message invocation macros. */~%")
269 (dolist (entry (vtmsgs-entries vtmsgs))
270 (emit-message-macro class entry stream))
273 (defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer)
275 ;; Output a structure member definition for each instance slot.
276 (dolist (slot (sod-class-slots class))
277 (hook-output slot 'islots sequencer))
279 ;; Generate a vtmsgs structure for all superclasses.
280 (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer))
282 ;;;--------------------------------------------------------------------------
283 ;;; Instance structure.
285 (defmethod hook-output ((slot sod-slot) (reason (eql 'islots)) sequencer)
286 (sequence-output (stream sequencer)
287 (((sod-slot-class slot) :islots :slots)
288 (pprint-logical-block (stream nil :prefix " " :suffix ";")
289 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
292 (defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer)
293 (with-slots ((class %class)) ilayout
294 (sequence-output (stream sequencer)
295 ((class :ilayout :start)
296 (format stream "/* Instance layout. */~@
298 (ilayout-struct-tag class)))
299 ((class :ilayout :end)
300 (format stream "};~2%")))))
302 (defmethod hook-output :after ((ilayout ilayout) (reason (eql :h)) sequencer)
303 (dolist (ichain (ilayout-ichains ilayout))
304 (hook-output ichain 'ilayout sequencer)))
306 (defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer)
307 (with-slots ((class %class) chain-head chain-tail) ichain
308 (when (eq class chain-tail)
309 (sequence-output (stream sequencer)
310 :constraint ((class :ichains :start)
311 (class :ichain chain-head :start)
312 (class :ichain chain-head :slots)
313 (class :ichain chain-head :end)
314 (class :ichains :end))
315 ((class :ichain chain-head :start)
316 (format stream "/* Instance chain structure. */~@
318 (ichain-struct-tag chain-tail chain-head)))
319 ((class :ichain chain-head :end)
320 (format stream "};~2%")
321 (format stream "/* Union of equivalent superclass chains. */~@
323 ~:{ struct ~A ~A;~%~}~
325 (ichain-union-tag chain-tail chain-head)
327 ;; Make sure the most specific class is first: only the
328 ;; first element of a union can be statically initialized in
330 (mapcar (lambda (super)
331 (list (ichain-struct-tag super chain-head)
332 (sod-class-nickname super)))
333 (sod-class-chain chain-tail))))))))
335 (defmethod hook-output ((ichain ichain) (reason (eql 'ilayout)) sequencer)
336 (with-slots ((class %class) chain-head chain-tail) ichain
337 (sequence-output (stream sequencer)
338 ((class :ilayout :slots)
339 (format stream " union ~A ~A;~%"
340 (ichain-union-tag chain-tail chain-head)
341 (sod-class-nickname chain-head))))))
343 (defmethod hook-output ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
344 (with-slots ((class %class) chain-head chain-tail) vtptr
345 (when (eq class chain-tail)
346 (sequence-output (stream sequencer)
347 ((class :ichain chain-head :slots)
348 (format stream " const struct ~A *_vt;~%"
349 (vtable-struct-tag chain-tail chain-head)))))))
351 (defmethod hook-output ((islots islots) (reason (eql :h)) sequencer)
352 (with-slots ((class %class) subclass slots) islots
353 (let ((head (sod-class-chain-head class)))
354 (when (eq head (sod-class-chain-head subclass))
355 (sequence-output (stream sequencer)
356 ((subclass :ichain (sod-class-chain-head class) :slots)
357 (format stream " struct ~A ~A;~%"
358 (islots-struct-tag class)
359 (sod-class-nickname class))))))))
361 ;;;--------------------------------------------------------------------------
362 ;;; Vtable structure.
364 (defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer)
365 (with-slots ((class %class)) method
366 (sequence-output (stream sequencer)
368 (let ((type (sod-method-function-type method)))
369 (princ "extern " stream)
370 (pprint-c-type (commentify-function-type type) stream
371 (sod-method-function-name method))
372 (format stream ";~%")))
373 ((class :methods :defs)
374 (let* ((type (sod-method-type method))
375 (keys (and (typep type 'c-keyword-function-type)
376 (c-function-keywords type))))
378 (format stream "struct ~A {~%~
379 ~{ unsigned ~A: 1;~%~}~
381 (direct-method-suppliedp-struct-tag method)
382 (mapcar #'argument-name keys))))))))
384 (defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer)
385 (with-slots ((class %class) chain-head chain-tail) vtable
386 (when (eq class chain-tail)
387 (sequence-output (stream sequencer)
388 :constraint ((class :vtables :start)
389 (class :vtable chain-head :start)
390 (class :vtable chain-head :slots)
391 (class :vtable chain-head :end)
392 (class :vtables :end))
393 ((class :vtable chain-head :start)
394 (format stream "/* Vtable structure. */~@
396 (vtable-struct-tag chain-tail chain-head)))
397 ((class :vtable chain-head :end)
398 (format stream "};~2%")
399 (format stream "/* Union of equivalent superclass vtables. */~@
401 ~:{ struct ~A ~A;~%~}~
403 (vtable-union-tag chain-tail chain-head)
405 ;; As for the ichain union, make sure the most specific
407 (mapcar (lambda (super)
408 (list (vtable-struct-tag super chain-head)
409 (sod-class-nickname super)))
410 (sod-class-chain chain-tail))))))
411 (sequence-output (stream sequencer)
412 ((class :vtable-externs)
413 (format stream "~@<extern const union ~A ~2I~_~A;~:>~%"
414 (vtable-union-tag chain-tail chain-head)
415 (vtable-name class chain-head))))))
417 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
418 (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
419 (when (eq subclass chain-tail)
420 (sequence-output (stream sequencer)
421 ((subclass :vtable chain-head :slots)
422 (format stream " struct ~A ~A;~%"
423 (vtmsgs-struct-tag subclass class)
424 (sod-class-nickname class)))))))
426 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
427 (when (vtmsgs-entries vtmsgs)
428 (with-slots ((class %class) subclass) vtmsgs
429 (sequence-output (stream sequencer)
430 :constraint ((subclass :vtmsgs :start)
431 (subclass :vtmsgs class :start)
432 (subclass :vtmsgs class :slots)
433 (subclass :vtmsgs class :end)
434 (subclass :vtmsgs :end))
435 ((subclass :vtmsgs class :start)
436 (format stream "/* Messages protocol from class ~A */~@
439 (vtmsgs-struct-tag subclass class)))
440 ((subclass :vtmsgs class :end)
441 (format stream "};~2%"))))))
443 (defmethod hook-output ((entry method-entry)
444 (reason (eql 'vtmsgs)) sequencer)
445 (let* ((method (method-entry-effective-method entry))
446 (message (effective-method-message method))
447 (class (effective-method-class method))
448 (function-type (method-entry-function-type entry))
449 (commented-type (commentify-function-type function-type))
450 (pointer-type (make-pointer-type commented-type)))
451 (sequence-output (stream sequencer)
452 ((class :vtmsgs (sod-message-class message) :slots)
453 (pprint-logical-block (stream nil :prefix " " :suffix ";")
454 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
457 (defmethod hook-output ((cptr class-pointer) (reason (eql :h)) sequencer)
458 (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
459 (when (eq chain-head (sod-class-chain-head class))
460 (sequence-output (stream sequencer)
461 ((class :vtable chain-head :slots)
462 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
464 (and (sod-class-direct-superclasses meta-chain-head)
465 (sod-class-nickname meta-chain-head))))))))
467 (defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer)
468 (with-slots ((class %class) chain-head) boff
469 (when (eq chain-head (sod-class-chain-head class))
470 (sequence-output (stream sequencer)
471 ((class :vtable chain-head :slots)
472 (write-line " size_t _base;" stream))))))
474 (defmethod hook-output ((choff chain-offset) (reason (eql :h)) sequencer)
475 (with-slots ((class %class) chain-head target-head) choff
476 (when (eq chain-head (sod-class-chain-head class))
477 (sequence-output (stream sequencer)
478 ((class :vtable chain-head :slots)
479 (format stream " ptrdiff_t _off_~A;~%"
480 (sod-class-nickname target-head)))))))
482 ;;;--------------------------------------------------------------------------
483 ;;; Implementation output.
485 (export '*instance-class*)
486 (defvar *instance-class* nil
487 "The class currently being output.
489 This is bound during the `hook-output' traversal of a class layout for
490 `:c' output, since some of the objects traversed actually `belong' to
491 superclasses and there's no other way to find out what the reference class
494 It may be bound at other times.")
496 (defmethod hook-output ((class sod-class) (reason (eql :c)) sequencer)
497 (sequence-output (stream sequencer)
502 (class :direct-methods :start) (class :direct-methods :end)
503 (class :effective-methods)
504 (class :vtables :start) (class :vtables :end)
505 (class :object :prepare) (class :object :start) (class :object :end)
509 (banner (format nil "Class ~A" class) stream))
511 ((class :object :start)
513 /* The class object. */
514 const struct ~A ~A__classobj = {~%"
515 (ilayout-struct-tag (sod-class-metaclass class))
517 ((class :object :end)
518 (format stream "};~2%"))))
520 (defmethod hook-output :after ((class sod-class) (reason (eql :c)) sequencer)
521 (let ((*instance-class* class))
522 (hook-output (sod-class-ilayout (sod-class-metaclass class))
525 ;;;--------------------------------------------------------------------------
526 ;;; Direct and effective methods.
528 (defmethod hook-output ((method delegating-direct-method)
529 (reason (eql :c)) sequencer)
530 (with-slots ((class %class) body) method
532 (return-from hook-output))
533 (sequence-output (stream sequencer)
534 ((class :direct-method method :start)
535 (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
536 (mapcar #'argument-name
537 (c-function-arguments (sod-method-next-method-type
539 ((class :direct-method method :end)
540 (format stream "#undef CALL_NEXT_METHOD~%"))))
543 (defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer)
544 (with-slots ((class %class) role body message) method
546 (return-from hook-output))
547 (sequence-output (stream sequencer)
548 :constraint ((class :direct-methods :start)
549 (class :direct-method method :banner)
550 (class :direct-method method :start)
551 (class :direct-method method :body)
552 (class :direct-method method :end)
553 (class :direct-methods :end))
554 ((class :direct-method method :banner)
555 (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
556 on `~A.~A' ~:_defined by `~A'."
559 (sod-message-class message))
560 (sod-message-name message)
563 ((class :direct-method method :body)
564 (pprint-c-type (sod-method-function-type method)
566 (sod-method-function-name method))
567 (format stream "~&{~%")
568 (write body :stream stream :pretty nil :escape nil)
569 (format stream "~&}~%"))
570 ((class :direct-method method :end)
573 (defmethod hook-output ((method basic-effective-method)
574 (reason (eql :c)) sequencer)
575 (with-slots ((class %class) functions) method
576 (sequence-output (stream sequencer)
577 ((class :effective-methods)
578 (let* ((keys (effective-method-keywords method))
579 (message (effective-method-message method))
580 (msg-class (sod-message-class message)))
582 (format-banner-comment stream "Keyword argument structure ~:_~
583 for `~A.~A' ~:_on class `~A'."
584 (sod-class-nickname msg-class)
585 (sod-message-name message)
587 (format stream "~&struct ~A {~%"
588 (effective-method-keyword-struct-tag method))
589 (format stream "~{ unsigned ~A__suppliedp: 1;~%~}"
590 (mapcar #'argument-name keys))
592 (write-string " " stream)
593 (pprint-c-type (argument-type key) stream (argument-name key))
594 (format stream ";~%"))
595 (format stream "};~2%")))
596 (dolist (func functions)
597 (write func :stream stream :escape nil :circle nil))))))
599 ;;;--------------------------------------------------------------------------
602 (defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer)
603 (with-slots ((class %class) chain-head chain-tail) vtable
604 (sequence-output (stream sequencer)
605 :constraint ((class :vtables :start)
606 (class :vtable chain-head :start)
607 (class :vtable chain-head :end)
608 (class :vtables :end))
609 ((class :vtable chain-head :start)
610 (format stream "/* Vtable for ~A chain. */~@
611 const union ~A ~A = { {~%"
613 (vtable-union-tag chain-tail chain-head)
614 (vtable-name class chain-head)))
615 ((class :vtable chain-head :end)
616 (format stream "} };~2%")))))
618 (defmethod hook-output ((cptr class-pointer) (reason (eql :c)) sequencer)
619 (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
620 (sequence-output (stream sequencer)
621 :constraint ((class :vtable chain-head :start)
622 (class :vtable chain-head :class-pointer metaclass)
623 (class :vtable chain-head :end))
624 ((class :vtable chain-head :class-pointer metaclass)
625 (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%"
626 (if (sod-class-direct-superclasses meta-chain-head)
627 (format nil "_cls_~A"
628 (sod-class-nickname meta-chain-head))
631 (sod-class-nickname meta-chain-head)
632 (sod-class-nickname metaclass))))))
634 (defmethod hook-output ((boff base-offset) (reason (eql :c)) sequencer)
635 (with-slots ((class %class) chain-head) boff
636 (sequence-output (stream sequencer)
637 :constraint ((class :vtable chain-head :start)
638 (class :vtable chain-head :base-offset)
639 (class :vtable chain-head :end))
640 ((class :vtable chain-head :base-offset)
641 (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%"
643 (ilayout-struct-tag class)
644 (sod-class-nickname chain-head))))))
646 (defmethod hook-output ((choff chain-offset) (reason (eql :c)) sequencer)
647 (with-slots ((class %class) chain-head target-head) choff
648 (sequence-output (stream sequencer)
649 :constraint ((class :vtable chain-head :start)
650 (class :vtable chain-head :chain-offset target-head)
651 (class :vtable chain-head :end))
652 ((class :vtable chain-head :chain-offset target-head)
653 (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
654 (format nil "_off_~A" (sod-class-nickname target-head))
655 (ilayout-struct-tag class)
656 (sod-class-nickname chain-head)
657 (sod-class-nickname target-head))))))
659 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
660 (with-slots ((class %class) subclass chain-head) vtmsgs
661 (sequence-output (stream sequencer)
662 :constraint ((subclass :vtable chain-head :start)
663 (subclass :vtable chain-head :vtmsgs class :start)
664 (subclass :vtable chain-head :vtmsgs class :slots)
665 (subclass :vtable chain-head :vtmsgs class :end)
666 (subclass :vtable chain-head :end))
667 ((subclass :vtable chain-head :vtmsgs class :start)
668 (format stream " { /* Method entries for ~A messages. */~%"
670 ((subclass :vtable chain-head :vtmsgs class :end)
671 (format stream " },~%")))))
673 (defmethod hook-output ((entry method-entry) (reason (eql :c)) sequencer)
674 (with-slots ((method %method) chain-head chain-tail role) entry
675 (let* ((message (effective-method-message method))
676 (class (effective-method-class method))
677 (super (sod-message-class message)))
678 (sequence-output (stream sequencer)
679 ((class :vtable chain-head :vtmsgs super :slots)
680 (format stream " /* ~19@A = */ ~A,~%"
681 (method-entry-slot-name entry)
682 (method-entry-function-name method chain-head role)))))))
684 ;;;--------------------------------------------------------------------------
685 ;;; Filling in the class object.
687 (defmethod hook-output ((ichain ichain) (reason (eql 'class)) sequencer)
688 (with-slots ((class %class) chain-head) ichain
689 (sequence-output (stream sequencer)
690 :constraint ((*instance-class* :object :start)
691 (*instance-class* :object chain-head :ichain :start)
692 (*instance-class* :object chain-head :ichain :end)
693 (*instance-class* :object :end))
694 ((*instance-class* :object chain-head :ichain :start)
695 (format stream " { { /* ~A ichain */~%"
696 (sod-class-nickname chain-head)))
697 ((*instance-class* :object chain-head :ichain :end)
698 (format stream " } },~%")))))
700 (defmethod hook-output ((islots islots) (reason (eql 'class)) sequencer)
701 (with-slots ((class %class)) islots
702 (let ((chain-head (sod-class-chain-head class)))
703 (sequence-output (stream sequencer)
704 :constraint ((*instance-class* :object chain-head :ichain :start)
705 (*instance-class* :object class :slots :start)
706 (*instance-class* :object class :slots)
707 (*instance-class* :object class :slots :end)
708 (*instance-class* :object chain-head :ichain :end))
709 ((*instance-class* :object class :slots :start)
710 (format stream " { /* Class ~A */~%" class))
711 ((*instance-class* :object class :slots :end)
712 (format stream " },~%"))))))
714 (defmethod hook-output ((vtptr vtable-pointer)
715 (reason (eql 'class)) sequencer)
716 (with-slots ((class %class) chain-head chain-tail) vtptr
717 (sequence-output (stream sequencer)
718 :constraint ((*instance-class* :object chain-head :ichain :start)
719 (*instance-class* :object chain-head :vtable)
720 (*instance-class* :object chain-head :ichain :end))
721 ((*instance-class* :object chain-head :vtable)
722 (format stream " /* ~17@A = */ &~A.~A,~%"
724 (vtable-name class chain-head)
725 (sod-class-nickname chain-tail))))))
727 (defgeneric output-class-initializer (slot instance stream)
728 (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
729 (let ((func (effective-slot-initializer-function slot))
730 (direct-slot (effective-slot-direct-slot slot)))
732 (format stream " /* ~15@A = */ ~A,~%"
733 (sod-slot-name direct-slot)
734 (funcall func instance))
735 (call-next-method))))
736 (:method ((slot effective-slot) (instance sod-class) stream)
737 (let ((init (find-class-initializer slot instance))
738 (direct-slot (effective-slot-direct-slot slot)))
739 (format stream " /* ~15@A = */ ~A,~%"
740 (sod-slot-name direct-slot)
741 (sod-initializer-value init)))))
743 (defmethod hook-output ((slot sod-class-effective-slot)
744 (reason (eql 'class)) sequencer)
745 (let ((instance *instance-class*)
746 (func (effective-slot-prepare-function slot)))
748 (sequence-output (stream sequencer)
749 ((instance :object :prepare)
750 (funcall func instance stream)))))
753 (defmethod hook-output ((slot effective-slot)
754 (reason (eql 'class)) sequencer)
755 (with-slots ((class %class) (dslot slot)) slot
756 (let ((instance *instance-class*)
757 (super (sod-slot-class dslot)))
758 (sequence-output (stream sequencer)
759 ((instance :object super :slots)
760 (output-class-initializer slot instance stream))))))
762 ;;;----- That's all, folks --------------------------------------------------