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 "Register hooks for the class layout, direct methods, effective methods,
34 (with-slots ((ilayout %ilayout) vtables methods effective-methods) class
35 (hook-output ilayout reason sequencer)
36 (dolist (method methods) (hook-output method reason sequencer))
37 (dolist (method effective-methods) (hook-output method reason sequencer))
38 (dolist (vtable vtables) (hook-output vtable reason sequencer))))
40 (defmethod hook-output :after ((ilayout ilayout) reason sequencer)
41 "Register hooks for the layout's ichains."
42 (with-slots (ichains) ilayout
43 (dolist (ichain ichains) (hook-output ichain reason sequencer))))
45 (defmethod hook-output :after ((ichain ichain) reason sequencer)
46 "Register hooks for the ichain body's items."
47 (dolist (item (ichain-body ichain)) (hook-output item reason sequencer)))
49 (defmethod hook-output :after ((islots islots) reason sequencer)
50 "Register hooks for the islots structure's individual slots."
51 (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer)))
53 (defmethod hook-output :after ((vtable vtable) reason sequencer)
54 "Register hooks for the vtable body's items."
55 (with-slots (body) vtable
56 (dolist (item body) (hook-output item reason sequencer))))
58 (defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer)
59 "Register hooks for the vtmsgs structure's individual method entries."
60 (with-slots (entries) vtmsgs
61 (dolist (entry entries) (hook-output entry reason sequencer))))
63 ;;;--------------------------------------------------------------------------
64 ;;; Class declarations.
66 (export 'emit-class-typedef)
67 (defgeneric emit-class-typedef (class stream)
69 "Emit a `typedef' for the CLASS's C class type to the output STREAM.
71 By default, this will be an alias for the class's home `ichain'
73 (defmethod emit-class-typedef ((class sod-class) stream)
74 (format stream "typedef struct ~A ~A;~%"
75 (ichain-struct-tag class (sod-class-chain-head class)) class))
77 (export 'emit-class-object-decl)
78 (defgeneric emit-class-object-decl (class stream)
80 "Emit the declaration and macros for the CLASS's class object.
82 This includes the main declaration, and the convenience macros for
83 referring to the class object's individual chains. Write everything to
85 (defmethod emit-class-object-decl ((class sod-class) stream)
86 (let ((metaclass (sod-class-metaclass class))
87 (metaroot (find-root-metaclass class)))
89 ;; Output the actual class object declaration, and the special
90 ;; `...__class' macro for the root-metaclass chain.
91 (format stream "/* The class object. */~@
92 extern const struct ~A ~A__classobj;~@
93 #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%"
94 (ilayout-struct-tag metaclass) class
95 (sod-class-nickname (sod-class-chain-head metaroot))
96 (sod-class-nickname metaroot))
98 ;; Write the uglier `...__cls_...' macros for the class object's other
100 (dolist (chain (sod-class-chains metaclass))
101 (let ((tail (car chain)))
102 (unless (eq tail metaroot)
103 (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%"
104 class (sod-class-nickname (sod-class-chain-head tail))
105 (sod-class-nickname tail)))))
108 (export 'emit-class-conversion-macro)
109 (defgeneric emit-class-conversion-macro (class super stream)
111 "Emit a macro for converting an instance of CLASS to an instance of SUPER.
113 By default this is named `CLASS__CONV_SPR'. In-chain upcasts are just a
114 trivial pointer cast, which any decent compiler will elide; cross-chain
115 upcasts use the `SOD_XCHAIN' macro. Write the macro to the output
117 (defmethod emit-class-conversion-macro
118 ((class sod-class) (super sod-class) stream)
119 (let ((super-head (sod-class-chain-head super)))
120 (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
121 ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
122 class (sod-class-nickname super) super
123 (eq super-head (sod-class-chain-head class))
124 (sod-class-nickname super-head))))
126 (export 'emit-message-macro-defn)
127 (defgeneric emit-message-macro-defn
128 (class entry varargsp me in-names out-names stream)
130 "Output a message macro for invoking a method ENTRY, with given arguments.
132 The default method on `emit-message-macro' calcualates the necessary
133 argument lists and calls this function to actually write the necessary
134 `#define' line to the stream. The intended division of responsibilities
135 is that `emit-message-macro' handles the peculiarities of marshalling the
136 arguments to the method entry function, while `emit-message-macro-defn'
137 concerns itself with navigating the vtable to find the right function in
139 (:method :around ((class sod-class) (entry method-entry)
140 varargsp me in-names out-names
142 (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
144 (when varargsp (format stream "#endif~%"))))
145 (defmethod emit-message-macro-defn ((class sod-class) (entry method-entry)
146 varargsp me in-names out-names
148 (format stream "#define ~A(~{~A~^, ~}) (~A)->_vt->~A.~A(~{~A~^, ~})~%"
149 (message-macro-name class entry)
152 (sod-class-nickname class)
153 (method-entry-slot-name entry)
156 (export 'emit-message-macro)
157 (defgeneric emit-message-macro (class entry stream)
159 "Write a macro for invoking the method ENTRY on an instance of CLASS.
161 The default behaviour is quite complicated, particular when varargs or
162 keyword messages are involved."))
163 (defmethod emit-message-macro ((class sod-class) (entry method-entry) stream)
164 (when (some (lambda (message)
165 (or (keyword-message-p message)
166 (varargs-message-p message)))
167 (sod-class-messages class)))
168 (let* ((type (method-entry-function-type entry))
169 (args (c-function-arguments type))
170 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
171 (do ((args args (cdr args)))
173 (let* ((raw-name (princ-to-string (argument-name (car args))))
174 (name (if (find raw-name
176 (sod-class-nickname class)
177 (method-entry-slot-name entry))
179 (format nil "sod__a_~A" raw-name)
181 (cond ((and (cdr args) (eq (cadr args) :ellipsis))
183 (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
184 (push (format nil "/*~A*/ ..." name) in-names)
185 (push "__VA_ARGS__" out-names)
189 (push name out-names)))))
190 (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
191 (emit-message-macro-defn class entry varargsp me
195 (when varargsp (format stream "#endif~%"))))
197 (defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer)
198 "Write the skeleton of a class declaration.
200 Most of the work is done by other functions.
202 * The class type is defined by `emit-class-typedef'.
204 * The class object is declared by `emit-class-object-decl'.
206 * The upcast conversion macros are defined by `emit-class-conversion-
209 * The message invocation macros are defined by `emit-message-macro'.
211 * The class instance structure itself is constructed by the `ilayout'
214 * The various vtable structures are constructed by the `vtable'
217 ;; Main output sequencing.
218 (sequence-output (stream sequencer)
223 (class :islots :start) (class :islots :slots) (class :islots :end)
224 (class :vtmsgs :start) (class :vtmsgs :end)
225 (class :vtables :start) (class :vtables :end)
226 (class :vtable-externs) (class :vtable-externs-after)
227 (class :methods :start) (class :methods :defs)
228 (class :methods) (class :methods :end)
229 (class :ichains :start) (class :ichains :end)
230 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
232 (class :message-macros)
236 (:typedefs (emit-class-typedef class stream))
237 ((class :banner) (banner (format nil "Class ~A" class) stream))
238 ((class :vtable-externs-after) (terpri stream))
239 ((class :vtable-externs) (format stream "/* Vtable structures. */~%"))
240 ((class :object) (emit-class-object-decl class stream)))
242 ;; Maybe generate an islots structure.
243 (when (sod-class-slots class)
244 (sequence-output (stream sequencer)
245 ((class :islots :start)
246 (format stream "/* Instance slots. */~@
248 (islots-struct-tag class)))
249 ((class :islots :end)
250 (format stream "};~2%"))))
252 ;; Declare the direct methods.
253 (when (sod-class-methods class)
254 (sequence-output (stream sequencer)
255 ((class :methods :start)
256 (format stream "/* Direct methods. */~%"))
257 ((class :methods :end)
260 ;; Provide upcast macros which do the right thing.
261 (when (sod-class-direct-superclasses class)
262 (sequence-output (stream sequencer)
263 ((class :conversions)
264 (format stream "/* Conversion macros. */~%")
265 (dolist (super (cdr (sod-class-precedence-list class)))
266 (emit-class-conversion-macro class super stream))
269 ;; Provide convenience macros for sending the newly defined messages. (The
270 ;; macros work on all subclasses too.)
272 ;; We need each message's method entry type for this, so we need to dig it
273 ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
274 ;; entries for precisely the messages we want to make macros for.
275 (when (some (lambda (message)
276 (or (keyword-message-p message)
277 (varargs-message-p message)))
278 (sod-class-messages class))
279 (one-off-output 'varargs-macros sequencer :early-decls
282 "~%SOD__VARARGS_MACROS_PREAMBLE~%"))))
283 (when (sod-class-messages class)
284 (sequence-output (stream sequencer)
285 ((class :message-macros)
286 (let* ((vtable (find (sod-class-chain-head class)
287 (sod-class-vtables class)
288 :key #'vtable-chain-head))
289 (vtmsgs (find-if (lambda (item)
290 (and (typep item 'vtmsgs)
291 (eql (vtmsgs-class item) class)))
292 (vtable-body vtable))))
293 (format stream "/* Message invocation macros. */~%")
294 (dolist (entry (vtmsgs-entries vtmsgs))
295 (emit-message-macro class entry stream))
298 (defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer)
299 "Register hooks to output CLASS's direct slots and messages."
301 ;; Output a structure member definition for each instance slot.
302 (dolist (slot (sod-class-slots class))
303 (hook-output slot 'islots sequencer))
305 ;; Generate a vtmsgs structure for all superclasses.
306 (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer))
308 ;;;--------------------------------------------------------------------------
309 ;;; Instance structure.
311 (defmethod hook-output ((slot sod-slot) (reason (eql 'islots)) sequencer)
312 "Declare the member for an individual slot within an `islots' structure."
313 (sequence-output (stream sequencer)
314 (((sod-slot-class slot) :islots :slots)
315 (pprint-logical-block (stream nil :prefix " " :suffix ";")
316 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
319 (defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer)
320 "Define the structure for a class layout.
322 Here we just provide the outermost structure. It gets filled in by
323 the `ichains' objects and their body items."
324 (with-slots ((class %class) ichains) ilayout
325 (sequence-output (stream sequencer)
326 ((class :ilayout :start)
327 (format stream "/* Instance layout. */~@
329 (ilayout-struct-tag class)))
330 ((class :ilayout :end)
331 (format stream "};~2%")))))
333 (defmethod hook-output :after ((ilayout ilayout) (reason (eql :h)) sequencer)
334 "Register hooks to write chain members into the overall class layout."
335 (dolist (ichain (ilayout-ichains ilayout))
336 (hook-output ichain 'ilayout sequencer)))
338 (defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer)
339 "Define the layout structure for a particular chain of a class.
341 A member of this class is dropped into the `ilayout' structure by the
342 corresponding method for the `ilayout' reason.
344 We define both the chain structure of the class, and a union of it with
345 all of its in-chain superclasses (so as to invoke the common-prefix
347 (with-slots ((class %class) chain-head chain-tail) ichain
348 (when (eq class chain-tail)
349 (sequence-output (stream sequencer)
350 :constraint ((class :ichains :start)
351 (class :ichain chain-head :start)
352 (class :ichain chain-head :slots)
353 (class :ichain chain-head :end)
354 (class :ichains :end))
355 ((class :ichain chain-head :start)
356 (format stream "/* Instance chain structure. */~@
358 (ichain-struct-tag chain-tail chain-head)))
359 ((class :ichain chain-head :end)
360 (format stream "};~2%")
361 (format stream "/* Union of equivalent superclass chains. */~@
363 ~:{ struct ~A ~A;~%~}~
365 (ichain-union-tag chain-tail chain-head)
367 ;; Make sure the most specific class is first: only the
368 ;; first element of a union can be statically initialized in
370 (mapcar (lambda (super)
371 (list (ichain-struct-tag super chain-head)
372 (sod-class-nickname super)))
373 (sod-class-chain chain-tail))))))))
375 (defmethod hook-output ((ichain ichain) (reason (eql 'ilayout)) sequencer)
376 "Declare the member for a class chain within the class layout."
377 (with-slots ((class %class) chain-head chain-tail) ichain
378 (sequence-output (stream sequencer)
379 ((class :ilayout :slots)
380 (format stream " union ~A ~A;~%"
381 (ichain-union-tag chain-tail chain-head)
382 (sod-class-nickname chain-head))))))
384 (defmethod hook-output ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
385 "Declare the member for a vtable pointer within an `ichain' structure."
386 (with-slots ((class %class) chain-head chain-tail) vtptr
387 (when (eq class chain-tail)
388 (sequence-output (stream sequencer)
389 ((class :ichain chain-head :slots)
390 (format stream " const struct ~A *_vt;~%"
391 (vtable-struct-tag chain-tail chain-head)))))))
393 (defmethod hook-output ((islots islots) (reason (eql :h)) sequencer)
394 "Declare the member for a class's `islots' within an `ichain' structure."
395 (with-slots ((class %class) subclass slots) islots
396 (let ((head (sod-class-chain-head class)))
397 (when (eq head (sod-class-chain-head subclass))
398 (sequence-output (stream sequencer)
399 ((subclass :ichain (sod-class-chain-head class) :slots)
400 (format stream " struct ~A ~A;~%"
401 (islots-struct-tag class)
402 (sod-class-nickname class))))))))
404 ;;;--------------------------------------------------------------------------
405 ;;; Vtable structure.
407 (defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer)
408 "Emit declarations for a direct method.
410 We declare the direct method function, and, if necessary, the `suppliedp'
411 structure for its keyword arguments."
413 (with-slots ((class %class)) method
414 (sequence-output (stream sequencer)
416 (let ((type (sod-method-function-type method)))
417 (princ "extern " stream)
418 (pprint-c-type (commentify-function-type type) stream
419 (sod-method-function-name method))
420 (format stream ";~%")))
421 ((class :methods :defs)
422 (let* ((type (sod-method-type method))
423 (keys (and (typep type 'c-keyword-function-type)
424 (c-function-keywords type))))
426 (format stream "struct ~A {~%~
427 ~{ unsigned ~A: 1;~%~}~
429 (direct-method-suppliedp-struct-tag method)
430 (mapcar #'argument-name keys))))))))
432 (defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer)
433 "Define the structure for a vtable.
435 We define the vtable structure of the class, and a union of it with all of
436 its in-chain superclasses (so as to invoke the common-prefix rule). We
437 also declare the vtable object, defined by the corresponding `:c' method."
438 (with-slots ((class %class) chain-head chain-tail) vtable
439 (when (eq class chain-tail)
440 (sequence-output (stream sequencer)
441 :constraint ((class :vtables :start)
442 (class :vtable chain-head :start)
443 (class :vtable chain-head :slots)
444 (class :vtable chain-head :end)
445 (class :vtables :end))
446 ((class :vtable chain-head :start)
447 (format stream "/* Vtable structure. */~@
449 (vtable-struct-tag chain-tail chain-head)))
450 ((class :vtable chain-head :end)
451 (format stream "};~2%")
452 (format stream "/* Union of equivalent superclass vtables. */~@
454 ~:{ struct ~A ~A;~%~}~
456 (vtable-union-tag chain-tail chain-head)
458 ;; As for the ichain union, make sure the most specific
460 (mapcar (lambda (super)
461 (list (vtable-struct-tag super chain-head)
462 (sod-class-nickname super)))
463 (sod-class-chain chain-tail))))))
464 (sequence-output (stream sequencer)
465 ((class :vtable-externs)
466 (format stream "~@<extern const union ~A ~2I~_~A;~:>~%"
467 (vtable-union-tag chain-tail chain-head)
468 (vtable-name class chain-head))))))
470 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
471 "Declare the member for a class's `vtmsgs' within a `vtable' structure."
472 (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
473 (when (eq subclass chain-tail)
474 (sequence-output (stream sequencer)
475 ((subclass :vtable chain-head :slots)
476 (format stream " struct ~A ~A;~%"
477 (vtmsgs-struct-tag subclass class)
478 (sod-class-nickname class)))))))
480 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
481 "Define the `vtmsgs' structure for a class's method entry functions."
482 (when (vtmsgs-entries vtmsgs)
483 (with-slots ((class %class) subclass) vtmsgs
484 (sequence-output (stream sequencer)
485 :constraint ((subclass :vtmsgs :start)
486 (subclass :vtmsgs class :start)
487 (subclass :vtmsgs class :slots)
488 (subclass :vtmsgs class :end)
489 (subclass :vtmsgs :end))
490 ((subclass :vtmsgs class :start)
491 (format stream "/* Messages protocol from class ~A */~@
494 (vtmsgs-struct-tag subclass class)))
495 ((subclass :vtmsgs class :end)
496 (format stream "};~2%"))))))
498 (defmethod hook-output ((entry method-entry)
499 (reason (eql 'vtmsgs)) sequencer)
500 "Declare the member for a method entry within a `vtmsgs' structure."
501 (let* ((method (method-entry-effective-method entry))
502 (message (effective-method-message method))
503 (class (effective-method-class method))
504 (function-type (method-entry-function-type entry))
505 (commented-type (commentify-function-type function-type))
506 (pointer-type (make-pointer-type commented-type)))
507 (sequence-output (stream sequencer)
508 ((class :vtmsgs (sod-message-class message) :slots)
509 (pprint-logical-block (stream nil :prefix " " :suffix ";")
510 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
513 (defmethod hook-output ((cptr class-pointer) (reason (eql :h)) sequencer)
514 "Declare the member for a class-chain pointer within a `vtmsgs' structure."
515 (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
516 (when (eq chain-head (sod-class-chain-head class))
517 (sequence-output (stream sequencer)
518 ((class :vtable chain-head :slots)
519 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
521 (and (sod-class-direct-superclasses meta-chain-head)
522 (sod-class-nickname meta-chain-head))))))))
524 (defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer)
525 "Declare the member for the base offset within a `vtmsgs' structure."
526 (with-slots ((class %class) chain-head) boff
527 (when (eq chain-head (sod-class-chain-head class))
528 (sequence-output (stream sequencer)
529 ((class :vtable chain-head :slots)
530 (write-line " size_t _base;" stream))))))
532 (defmethod hook-output ((choff chain-offset) (reason (eql :h)) sequencer)
533 "Declare the member for a cross-chain offset within a `vtmsgs' structure."
534 (with-slots ((class %class) chain-head target-head) choff
535 (when (eq chain-head (sod-class-chain-head class))
536 (sequence-output (stream sequencer)
537 ((class :vtable chain-head :slots)
538 (format stream " ptrdiff_t _off_~A;~%"
539 (sod-class-nickname target-head)))))))
541 ;;;--------------------------------------------------------------------------
542 ;;; Static instance declarations.
544 (export 'declare-static-instance)
545 (defgeneric declare-static-instance (instance stream)
547 "Write a declaration for the static INSTANCE to STREAM.
549 Note that, according to whether the instance is external or private, this
550 may be written as part of the `:h' or `:c' reasons."))
551 (defmethod declare-static-instance (instance stream)
552 (with-slots ((class %class) name externp constp) instance
553 (format stream "~:[static~;extern~] ~:[~;const ~]struct ~
555 #define ~A (&~A__instance.~A.~A)~%"
556 externp constp (ilayout-struct-tag class) name
557 name name (sod-class-nickname (sod-class-chain-head class))
558 (sod-class-nickname class))))
560 (defmethod hook-output
561 ((instance static-instance) (reason (eql :h)) sequencer)
562 "Write an `extern' declaration for an external static instance."
563 (with-slots (externp) instance
565 (one-off-output 'static-instances-banner sequencer
566 '(:static-instances :start)
568 (banner "Public static instances" stream)))
569 (one-off-output 'static-instances-end sequencer
570 '(:static-instances :end)
572 (sequence-output (stream sequencer)
574 (declare-static-instance instance stream))))))
576 ;;;--------------------------------------------------------------------------
577 ;;; Implementation output.
579 (export '*instance-class*)
580 (defvar-unbound *instance-class*
581 "The class currently being output.
583 This is bound during the `hook-output' traversal of a class layout for
584 `:c' output, since some of the objects traversed actually `belong' to
585 superclasses and there's no other way to find out what the reference class
588 It may be bound at other times.")
590 (defmethod hook-output ((class sod-class) (reason (eql :c)) sequencer)
591 "Write the skeleton of a class definition.
593 Most of the work is done by other methods.
595 * The direct methods are defined by the `sod-method' objects.
597 * The effective method functions and related structures are defined by
598 the effective method objects.
600 * The vtable structures are initialized by the vtable objects and their
603 * The class structure and its associated tables are initialized by the
604 metaclass's layout objects."
606 (sequence-output (stream sequencer)
611 (class :direct-methods :start) (class :direct-methods :end)
612 (class :effective-methods)
613 (class :vtables :start) (class :vtables :end)
614 (class :object :prepare) (class :object :start) (class :object :end)
618 (banner (format nil "Class ~A" class) stream))
620 ((class :object :start)
622 /* The class object. */
623 const struct ~A ~A__classobj = {~%"
624 (ilayout-struct-tag (sod-class-metaclass class))
626 ((class :object :end)
627 (format stream "};~2%"))))
629 (defmethod hook-output :after ((class sod-class) (reason (eql :c)) sequencer)
630 "Register hooks to initialize the class object structure."
631 (let ((*instance-class* class))
632 (hook-output (sod-class-ilayout (sod-class-metaclass class))
635 ;;;--------------------------------------------------------------------------
636 ;;; Direct and effective methods.
638 (defmethod hook-output ((method delegating-direct-method)
639 (reason (eql :c)) sequencer)
640 "Define the `CALL_NEXT_METHOD' macro around a `delegating-direct-method'."
641 (with-slots ((class %class) body) method
643 (return-from hook-output))
644 (sequence-output (stream sequencer)
645 ((class :direct-method method :start)
646 (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
647 (mapcar #'argument-name
648 (c-function-arguments (sod-method-next-method-type
650 ((class :direct-method method :end)
651 (format stream "#undef CALL_NEXT_METHOD~%"))))
654 (defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer)
655 "Define a direct method function."
656 (with-slots ((class %class) role body message) method
658 (return-from hook-output))
659 (sequence-output (stream sequencer)
660 :constraint ((class :direct-methods :start)
661 (class :direct-method method :banner)
662 (class :direct-method method :start)
663 (class :direct-method method :body)
664 (class :direct-method method :end)
665 (class :direct-methods :end))
666 ((class :direct-method method :banner)
667 (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
668 on `~A.~A' ~:_defined by `~A'."
671 (sod-message-class message))
672 (sod-message-name message)
675 ((class :direct-method method :body)
676 (pprint-c-type (sod-method-function-type method)
678 (sod-method-function-name method))
679 (format stream "~&{~%")
680 (write body :stream stream :pretty nil :escape nil)
681 (format stream "~&}~%"))
682 ((class :direct-method method :end)
685 (defmethod hook-output ((method basic-effective-method)
686 (reason (eql :c)) sequencer)
687 "Define an effective method's functions.
689 Specifically, the method-entry functions and any auxiliary functions
690 needed to stitch everything together."
691 (with-slots ((class %class) functions) method
692 (sequence-output (stream sequencer)
693 ((class :effective-methods)
694 (let* ((keys (effective-method-keywords method))
695 (message (effective-method-message method))
696 (msg-class (sod-message-class message)))
698 (format-banner-comment stream "Keyword argument structure ~:_~
699 for `~A.~A' ~:_on class `~A'."
700 (sod-class-nickname msg-class)
701 (sod-message-name message)
703 (format stream "~&struct ~A {~%"
704 (effective-method-keyword-struct-tag method))
705 (format stream "~{ unsigned ~A__suppliedp: 1;~%~}"
706 (mapcar #'argument-name keys))
708 (write-string " " stream)
709 (pprint-c-type (argument-type key) stream (argument-name key))
710 (format stream ";~%"))
711 (format stream "};~2%")))
712 (dolist (func functions)
713 (write func :stream stream :escape nil :circle nil))))))
715 ;;;--------------------------------------------------------------------------
718 (defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer)
719 "Define a vtable structure.
721 Here we just provide the outermost structure. It gets filled in by the
722 vtable object's body items."
723 (with-slots ((class %class) chain-head chain-tail) vtable
724 (sequence-output (stream sequencer)
725 :constraint ((class :vtables :start)
726 (class :vtable chain-head :start)
727 (class :vtable chain-head :end)
728 (class :vtables :end))
729 ((class :vtable chain-head :start)
730 (format stream "/* Vtable for ~A chain. */~@
731 const union ~A ~A = { {~%"
733 (vtable-union-tag chain-tail chain-head)
734 (vtable-name class chain-head)))
735 ((class :vtable chain-head :end)
736 (format stream "} };~2%")))))
738 (defmethod hook-output ((cptr class-pointer) (reason (eql :c)) sequencer)
739 "Drop a class pointer into a vtable definition."
740 (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
741 (sequence-output (stream sequencer)
742 :constraint ((class :vtable chain-head :start)
743 (class :vtable chain-head :class-pointer metaclass)
744 (class :vtable chain-head :end))
745 ((class :vtable chain-head :class-pointer metaclass)
746 (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%"
747 (if (sod-class-direct-superclasses meta-chain-head)
748 (format nil "_cls_~A"
749 (sod-class-nickname meta-chain-head))
752 (sod-class-nickname meta-chain-head)
753 (sod-class-nickname metaclass))))))
755 (defmethod hook-output ((boff base-offset) (reason (eql :c)) sequencer)
756 "Drop a base offset into a vtable definition."
757 (with-slots ((class %class) chain-head) boff
758 (sequence-output (stream sequencer)
759 :constraint ((class :vtable chain-head :start)
760 (class :vtable chain-head :base-offset)
761 (class :vtable chain-head :end))
762 ((class :vtable chain-head :base-offset)
763 (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%"
765 (ilayout-struct-tag class)
766 (sod-class-nickname chain-head))))))
768 (defmethod hook-output ((choff chain-offset) (reason (eql :c)) sequencer)
769 "Drop a cross-chain offset into a vtable definition."
770 (with-slots ((class %class) chain-head target-head) choff
771 (sequence-output (stream sequencer)
772 :constraint ((class :vtable chain-head :start)
773 (class :vtable chain-head :chain-offset target-head)
774 (class :vtable chain-head :end))
775 ((class :vtable chain-head :chain-offset target-head)
776 (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
777 (format nil "_off_~A" (sod-class-nickname target-head))
778 (ilayout-struct-tag class)
779 (sod-class-nickname chain-head)
780 (sod-class-nickname target-head))))))
782 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
783 "Define the method entry pointers for a superclass's messages.
785 We only provide the outer structure. It gets filled in by the
786 `method-entry' objects."
787 (with-slots ((class %class) subclass chain-head) vtmsgs
788 (sequence-output (stream sequencer)
789 :constraint ((subclass :vtable chain-head :start)
790 (subclass :vtable chain-head :vtmsgs class :start)
791 (subclass :vtable chain-head :vtmsgs class :slots)
792 (subclass :vtable chain-head :vtmsgs class :end)
793 (subclass :vtable chain-head :end))
794 ((subclass :vtable chain-head :vtmsgs class :start)
795 (format stream " { /* Method entries for ~A messages. */~%"
797 ((subclass :vtable chain-head :vtmsgs class :end)
798 (format stream " },~%")))))
800 (defmethod hook-output ((entry method-entry) (reason (eql :c)) sequencer)
801 "Define a method-entry pointer in a vtable."
802 (with-slots ((method %method) chain-head chain-tail role) entry
803 (let* ((message (effective-method-message method))
804 (class (effective-method-class method))
805 (super (sod-message-class message)))
806 (sequence-output (stream sequencer)
807 ((class :vtable chain-head :vtmsgs super :slots)
808 (format stream " /* ~19@A = */ ~A,~%"
809 (method-entry-slot-name entry)
810 (method-entry-function-name method chain-head role)))))))
812 ;;;--------------------------------------------------------------------------
813 ;;; Filling in the class object.
815 (defmethod hook-output ((ichain ichain) (reason (eql 'class)) sequencer)
816 "Define an instance chain of a class object.
818 Here we only provide the outer structure. It gets filled in by the
819 `ichain' object's body items."
820 (with-slots ((class %class) chain-head) ichain
821 (sequence-output (stream sequencer)
822 :constraint ((*instance-class* :object :start)
823 (*instance-class* :object chain-head :ichain :start)
824 (*instance-class* :object chain-head :ichain :end)
825 (*instance-class* :object :end))
826 ((*instance-class* :object chain-head :ichain :start)
827 (format stream " { { /* ~A ichain */~%"
828 (sod-class-nickname chain-head)))
829 ((*instance-class* :object chain-head :ichain :end)
830 (format stream " } },~%")))))
832 (defmethod hook-output ((islots islots) (reason (eql 'class)) sequencer)
833 "Define an instance's slots in a class object.
835 Here we only provide the outer structure. It gets filled in by the
836 individual slot objects."
837 (with-slots ((class %class)) islots
838 (let ((chain-head (sod-class-chain-head class)))
839 (sequence-output (stream sequencer)
840 :constraint ((*instance-class* :object chain-head :ichain :start)
841 (*instance-class* :object class :slots :start)
842 (*instance-class* :object class :slots)
843 (*instance-class* :object class :slots :end)
844 (*instance-class* :object chain-head :ichain :end))
845 ((*instance-class* :object class :slots :start)
846 (format stream " { /* Class ~A */~%" class))
847 ((*instance-class* :object class :slots :end)
848 (format stream " },~%"))))))
850 (defmethod hook-output ((vtptr vtable-pointer)
851 (reason (eql 'class)) sequencer)
852 "Define a vtable pointer in a class object."
853 (with-slots ((class %class) chain-head chain-tail) vtptr
854 (sequence-output (stream sequencer)
855 :constraint ((*instance-class* :object chain-head :ichain :start)
856 (*instance-class* :object chain-head :vtable)
857 (*instance-class* :object chain-head :ichain :end))
858 ((*instance-class* :object chain-head :vtable)
859 (format stream " /* ~17@A = */ &~A.~A,~%"
861 (vtable-name class chain-head)
862 (sod-class-nickname chain-tail))))))
864 (defgeneric output-class-initializer (slot instance stream)
866 "Define an individual slot in a class object.")
867 (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
868 "If this slot has an initializer function, then call it; otherwise try to
869 find an initializer as usual."
870 (let ((func (effective-slot-initializer-function slot))
871 (direct-slot (effective-slot-direct-slot slot)))
873 (format stream " /* ~15@A = */ ~A,~%"
874 (sod-slot-name direct-slot)
875 (funcall func instance))
876 (call-next-method))))
877 (:method ((slot effective-slot) (instance sod-class) stream)
878 "Initialize a class slot by looking up an applicable initializer."
879 (let ((init (find-class-initializer slot instance))
880 (direct-slot (effective-slot-direct-slot slot)))
881 (format stream " /* ~15@A = */ ~A,~%"
882 (sod-slot-name direct-slot)
883 (sod-initializer-value init)))))
885 (defmethod hook-output ((slot sod-class-effective-slot)
886 (reason (eql 'class)) sequencer)
887 "Write any necessary preparatory definitions for a class slot with a
888 computed initializer."
889 (let ((instance *instance-class*)
890 (func (effective-slot-prepare-function slot)))
892 (sequence-output (stream sequencer)
893 ((instance :object :prepare)
894 (funcall func instance stream)))))
897 (defmethod hook-output ((slot effective-slot)
898 (reason (eql 'class)) sequencer)
899 "Define a slot in a class object."
900 (with-slots ((class %class) (dslot slot)) slot
901 (let ((instance *instance-class*)
902 (super (sod-slot-class dslot)))
903 (sequence-output (stream sequencer)
904 ((instance :object super :slots)
905 (output-class-initializer slot instance stream))))))
907 ;;;--------------------------------------------------------------------------
908 ;;; Static instances.
910 (export '*static-instance*)
911 (defvar-unbound *static-instance*
912 "The static instance currently being output.
914 This is bound during the `hook-output' traversal of a static instance for
915 `:c', since the slots traversed need to be able to look up initializers
916 from the static instance definition.")
918 (defmethod hook-output ((instance static-instance)
919 (reason (eql :c)) sequencer)
920 "Write a static instance definition."
921 (with-slots (externp) instance
922 (one-off-output 'static-instances-banner sequencer
923 '(:static-instances :start)
925 (banner "Static instance definitions" stream)))
927 (one-off-output 'static-instances-forward sequencer
928 '(:static-instances :start)
930 (format stream "/* Forward declarations. */~%")))
931 (one-off-output 'static-instances-forward-gap sequencer
932 '(:static-instances :gap)
934 (sequence-output (stream sequencer)
935 ((:static-instances :decls)
936 (declare-static-instance instance stream))))))
938 (defmethod hook-output ((class sod-class)
939 (reason (eql 'static-instance)) sequencer)
940 "Output the framing around a static instance initializer."
941 (let ((instance *static-instance*))
942 (with-slots ((class %class) name externp constp) instance
943 (sequence-output (stream sequencer)
944 :constraint ((:static-instances :gap)
945 (*static-instance* :start)
946 (*static-instance* :end)
947 (:static-instances :end))
948 ((*static-instance* :start)
949 (format stream "/* Static instance `~A'. */~%~
950 ~:[static ~;~]~:[~;const ~]~
951 struct ~A ~A__instance = {~%"
954 (ilayout-struct-tag class) name))
955 ((*static-instance* :end)
956 (format stream "};~2%"))))))
958 (defmethod hook-output ((ichain ichain)
959 (reason (eql 'static-instance)) sequencer)
960 "Output the initializer for an ichain."
961 (with-slots ((class %class) chain-head chain-tail) ichain
962 (sequence-output (stream sequencer)
963 :constraint ((*static-instance* :start)
964 (*static-instance* :ichain chain-head :start)
965 (*static-instance* :ichain chain-head :end)
966 (*static-instance* :end))
967 ((*static-instance* :ichain chain-head :start)
968 (format stream " { { /* ~A ichain */~%"
969 (sod-class-nickname chain-head)))
970 ((*static-instance* :ichain chain-head :end)
971 (format stream " } },~%")))))
973 (defmethod hook-output ((islots islots)
974 (reason (eql 'static-instance)) sequencer)
975 "Initialize a static instance's slots."
976 (with-slots ((class %class)) islots
977 (let ((chain-head (sod-class-chain-head class)))
978 (sequence-output (stream sequencer)
980 ((*static-instance* :ichain chain-head :start)
981 (*static-instance* :slots class :start)
982 (*static-instance* :slots class)
983 (*static-instance* :slots class :end)
984 (*static-instance* :ichain chain-head :end))
985 ((*static-instance* :slots class :start)
986 (format stream " { /* Class ~A */~%" class))
987 ((*static-instance* :slots class :end)
988 (format stream " },~%"))))))
990 (defmethod hook-output ((vtptr vtable-pointer)
991 (reason (eql 'static-instance)) sequencer)
992 "Initialize a vtable pointer in a static instance.."
993 (with-slots ((class %class) chain-head chain-tail) vtptr
994 (sequence-output (stream sequencer)
995 :constraint ((*static-instance* :ichain chain-head :start)
996 (*static-instance* :vtable chain-head)
997 (*static-instance* :ichain chain-head :end))
998 ((*static-instance* :vtable chain-head)
999 (format stream " /* ~17@A = */ &~A.~A,~%"
1001 (vtable-name class chain-head)
1002 (sod-class-nickname chain-tail))))))
1004 (export 'output-static-instance-initializer)
1005 (defgeneric output-static-instance-initializer (instance slot stream)
1007 "Output an initializer for an effective SLOT in a static INSTANCE."))
1008 (defmethod output-static-instance-initializer ((instance static-instance)
1009 (slot effective-slot)
1011 (let* ((direct-slot (effective-slot-direct-slot slot))
1012 (init (or (find direct-slot
1013 (static-instance-initializers instance)
1014 :key #'sod-initializer-slot)
1015 (effective-slot-initializer slot))))
1016 (format stream " /* ~15@A = */ ~A,~%"
1017 (sod-slot-name direct-slot)
1018 (sod-initializer-value init))))
1020 (defmethod hook-output ((slot effective-slot)
1021 (reason (eql 'static-instance)) sequencer)
1022 "Initialize a slot in a static instance."
1023 (with-slots ((class %class) initializers) *static-instance*
1024 (with-slots ((dslot slot)) slot
1025 (let ((super (sod-slot-class dslot))
1026 (instance *static-instance*))
1027 (sequence-output (stream sequencer)
1028 ((instance :slots super)
1029 (output-static-instance-initializer instance slot stream)))))))
1031 (defmethod hook-output :after
1032 ((instance static-instance) (reason (eql :c)) sequencer)
1033 (with-slots ((class %class)) instance
1034 (let ((*static-instance* instance))
1035 (hook-output class 'static-instance sequencer))))
1037 ;;;----- That's all, folks --------------------------------------------------