5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
31 (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
33 ;; Main output sequencing.
34 (sequence-output (stream sequencer)
39 (class :islots :start) (class :islots :slots) (class :islots :end)
40 (class :vtmsgs :start) (class :vtmsgs :end)
41 (class :vtables :start) (class :vtables :end)
42 (class :vtable-externs) (class :vtable-externs-after)
43 (class :methods :start) (class :methods) (class :methods :end)
44 (class :ichains :start) (class :ichains :end)
45 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
47 (class :message-macros)
52 (format stream "typedef struct ~A ~A;~%"
53 (ichain-struct-tag class (sod-class-chain-head class)) class))
56 (banner (format nil "Class ~A" class) stream))
57 ((class :vtable-externs-after)
60 ((class :vtable-externs)
61 (format stream "/* Vtable structures. */~%"))
64 (let ((metaclass (sod-class-metaclass class))
65 (metaroot (find-root-metaclass class)))
66 (format stream "/* The class object. */~@
67 extern const struct ~A ~A__classobj;~@
68 #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
69 (ilayout-struct-tag metaclass) class
70 (sod-class-nickname (sod-class-chain-head metaroot))
71 (sod-class-nickname metaroot)))))
73 ;; Maybe generate an islots structure.
74 (when (sod-class-slots class)
75 (dolist (slot (sod-class-slots class))
76 (hook-output slot 'islots sequencer))
77 (sequence-output (stream sequencer)
78 ((class :islots :start)
79 (format stream "/* Instance slots. */~@
81 (islots-struct-tag class)))
83 (format stream "};~2%"))))
85 ;; Declare the direct methods.
86 (when (sod-class-methods class)
87 (sequence-output (stream sequencer)
88 ((class :methods :start)
89 (format stream "/* Direct methods. */~%"))
90 ((class :methods :end)
93 ;; Provide upcast macros which do the right thing.
94 (when (sod-class-direct-superclasses class)
95 (sequence-output (stream sequencer)
97 (let ((chain-head (sod-class-chain-head class)))
98 (format stream "/* Conversion macros. */~%")
99 (dolist (super (cdr (sod-class-precedence-list class)))
100 (let ((super-head (sod-class-chain-head super)))
101 (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
102 ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
103 class (sod-class-nickname super) super
104 (eq chain-head super-head)
105 (sod-class-nickname super-head))))
108 ;; Provide convenience macros for sending the newly defined messages. (The
109 ;; macros work on all subclasses too.)
111 ;; We need each message's method entry type for this, so we need to dig it
112 ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
113 ;; entries for precisely the messages we want to make macros for.
114 (when (sod-class-messages class)
115 (sequence-output (stream sequencer)
116 ((class :message-macros)
117 (let* ((vtable (find (sod-class-chain-head class)
118 (sod-class-vtables class)
119 :key #'vtable-chain-head))
120 (vtmsgs (find-if (lambda (item)
121 (and (typep item 'vtmsgs)
122 (eql (vtmsgs-class item) class)))
123 (vtable-body vtable))))
124 (format stream "/* Message invocation macros. */~%")
126 (dolist (entry (vtmsgs-entries vtmsgs))
127 (let* ((type (method-entry-function-type entry))
128 (args (c-function-arguments type))
129 (method (method-entry-effective-method entry))
130 (message (effective-method-message method))
131 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
132 (do ((args args (cdr args)))
134 (let* ((raw-name (argument-name (car args)))
135 (name (if (find raw-name
137 (sod-class-nickname class)
138 (sod-message-name message))
140 (format nil "sod__a_~A" raw-name)
142 (cond ((and (cdr args) (eq (cadr args) :ellipsis))
144 (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
145 (push (format nil "/*~A*/ ..." name) in-names)
146 (push "__VA_ARGS__" out-names)
150 (push name out-names)))))
152 (format stream "#if __STDC_VERSION__ >= 199901~%"))
153 (format stream "#define ~A(~{~A~^, ~}) ~
154 ~A->_vt->~A.~A(~{~A~^, ~})~%"
155 (message-macro-name class message)
158 (sod-class-nickname class)
159 (sod-message-name message)
160 (nreverse out-names))
162 (format stream "#endif~%"))))
165 ;; Generate vtmsgs structure for all superclasses.
166 (hook-output (car (sod-class-vtables class))
170 (defmethod hook-output progn ((class sod-class) reason sequencer)
171 (with-slots (ilayout vtables methods effective-methods) class
172 (hook-output ilayout reason sequencer)
173 (dolist (method methods) (hook-output method reason sequencer))
174 (dolist (method effective-methods) (hook-output method reason sequencer))
175 (dolist (vtable vtables) (hook-output vtable reason sequencer))))
177 ;;;--------------------------------------------------------------------------
178 ;;; Instance structure.
180 (defmethod hook-output progn ((slot sod-slot)
181 (reason (eql 'islots))
183 (sequence-output (stream sequencer)
184 (((sod-slot-class slot) :islots :slots)
185 (pprint-logical-block (stream nil :prefix " " :suffix ";")
186 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
189 (defmethod hook-output progn ((ilayout ilayout) reason sequencer)
190 (with-slots (ichains) ilayout
191 (dolist (ichain ichains) (hook-output ichain reason sequencer))))
193 (defmethod hook-output progn ((ichain ichain) reason sequencer)
194 (dolist (item (ichain-body ichain))
195 (hook-output item reason sequencer)))
197 (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer)
198 (with-slots (class ichains) ilayout
199 (sequence-output (stream sequencer)
200 ((class :ilayout :start)
201 (format stream "/* Instance layout. */~@
203 (ilayout-struct-tag class)))
204 ((class :ilayout :end)
205 (format stream "};~2%")))
206 (dolist (ichain ichains)
207 (hook-output ichain 'ilayout sequencer))))
209 (defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer)
210 (with-slots (class chain-head chain-tail) ichain
211 (when (eq class chain-tail)
212 (sequence-output (stream sequencer)
213 :constraint ((class :ichains :start)
214 (class :ichain chain-head :start)
215 (class :ichain chain-head :slots)
216 (class :ichain chain-head :end)
217 (class :ichains :end))
218 ((class :ichain chain-head :start)
219 (format stream "/* Instance chain structure. */~@
221 (ichain-struct-tag chain-tail chain-head)))
222 ((class :ichain chain-head :end)
223 (format stream "};~2%")
224 (format stream "/* Union of equivalent superclass chains. */~@
226 ~:{ struct ~A ~A;~%~}~
228 (ichain-union-tag chain-tail chain-head)
230 ;; Make sure the most specific class is first: only the
231 ;; first element of a union can be statically initialized in
233 (mapcar (lambda (super)
234 (list (ichain-struct-tag super chain-head)
235 (sod-class-nickname super)))
236 (sod-class-chain chain-tail))))))))
238 (defmethod hook-output progn ((ichain ichain)
239 (reason (eql 'ilayout))
241 (with-slots (class chain-head chain-tail) ichain
242 (sequence-output (stream sequencer)
243 ((class :ilayout :slots)
244 (format stream " union ~A ~A;~%"
245 (ichain-union-tag chain-tail chain-head)
246 (sod-class-nickname chain-head))))))
248 (defmethod hook-output progn ((vtptr vtable-pointer)
251 (with-slots (class chain-head chain-tail) vtptr
252 (sequence-output (stream sequencer)
253 ((class :ichain chain-head :slots)
254 (format stream " const struct ~A *_vt;~%"
255 (vtable-struct-tag chain-tail chain-head))))))
257 (defmethod hook-output progn ((islots islots) reason sequencer)
258 (dolist (slot (islots-slots islots))
259 (hook-output slot reason sequencer)))
261 (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
262 (with-slots (class subclass slots) islots
263 (sequence-output (stream sequencer)
264 ((subclass :ichain (sod-class-chain-head class) :slots)
265 (format stream " struct ~A ~A;~%"
266 (islots-struct-tag class)
267 (sod-class-nickname class))))))
269 ;;;--------------------------------------------------------------------------
270 ;;; Vtable structure.
272 (defmethod hook-output progn ((vtable vtable) reason sequencer)
273 (with-slots (body) vtable
274 (dolist (item body) (hook-output item reason sequencer))))
276 (defmethod hook-output progn ((method sod-method)
279 (with-slots (class) method
280 (sequence-output (stream sequencer)
282 (let ((type (sod-method-function-type method)))
283 (princ "extern " stream)
284 (pprint-c-type (commentify-function-type type) stream
285 (sod-method-function-name method))
286 (format stream ";~%"))))))
288 (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
289 (with-slots (class chain-head chain-tail) vtable
290 (when (eq class chain-tail)
291 (sequence-output (stream sequencer)
292 :constraint ((class :vtables :start)
293 (class :vtable chain-head :start)
294 (class :vtable chain-head :slots)
295 (class :vtable chain-head :end)
296 (class :vtables :end))
297 ((class :vtable chain-head :start)
298 (format stream "/* Vtable structure. */~@
300 (vtable-struct-tag chain-tail chain-head)))
301 ((class :vtable chain-head :end)
302 (format stream "};~2%"))))
303 (sequence-output (stream sequencer)
304 ((class :vtable-externs)
305 (format stream "~@<extern const struct ~A ~2I~_~A__vtable_~A;~:>~%"
306 (vtable-struct-tag chain-tail chain-head)
307 class (sod-class-nickname chain-head))))))
309 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
310 (with-slots (class subclass chain-head chain-tail) vtmsgs
311 (sequence-output (stream sequencer)
312 ((subclass :vtable chain-head :slots)
313 (format stream " struct ~A ~A;~%"
314 (vtmsgs-struct-tag subclass class)
315 (sod-class-nickname class))))))
317 (defmethod hook-output progn ((vtmsgs vtmsgs)
318 (reason (eql 'vtmsgs))
320 (when (vtmsgs-entries vtmsgs)
321 (with-slots (class subclass) vtmsgs
322 (sequence-output (stream sequencer)
323 :constraint ((subclass :vtmsgs :start)
324 (subclass :vtmsgs class :start)
325 (subclass :vtmsgs class :slots)
326 (subclass :vtmsgs class :end)
327 (subclass :vtmsgs :end))
328 ((subclass :vtmsgs class :start)
329 (format stream "/* Messages protocol from class ~A */~@
332 (vtmsgs-struct-tag subclass class)))
333 ((subclass :vtmsgs class :end)
334 (format stream "};~2%"))))))
336 (defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
337 (with-slots (entries) vtmsgs
338 (dolist (entry entries) (hook-output entry reason sequencer))))
340 (defmethod hook-output progn ((entry method-entry)
341 (reason (eql 'vtmsgs))
343 (let* ((method (method-entry-effective-method entry))
344 (message (effective-method-message method))
345 (class (effective-method-class method))
346 (function-type (method-entry-function-type entry))
347 (commented-type (commentify-function-type function-type))
348 (pointer-type (make-pointer-type commented-type)))
349 (sequence-output (stream sequencer)
350 ((class :vtmsgs (sod-message-class message) :slots)
351 (pprint-logical-block (stream nil :prefix " " :suffix ";")
352 (pprint-c-type pointer-type stream (sod-message-name message)))
355 (defmethod hook-output progn ((cptr class-pointer)
358 (with-slots (class chain-head metaclass meta-chain-head) cptr
359 (sequence-output (stream sequencer)
360 ((class :vtable chain-head :slots)
361 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
363 (and (sod-class-direct-superclasses meta-chain-head)
364 (sod-class-nickname meta-chain-head)))))))
366 (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
367 (with-slots (class chain-head) boff
368 (sequence-output (stream sequencer)
369 ((class :vtable chain-head :slots)
370 (write-line " size_t _base;" stream)))))
372 (defmethod hook-output progn ((choff chain-offset)
375 (with-slots (class chain-head target-head) choff
376 (sequence-output (stream sequencer)
377 ((class :vtable chain-head :slots)
378 (format stream " ptrdiff_t _off_~A;~%"
379 (sod-class-nickname target-head))))))
381 ;;;--------------------------------------------------------------------------
382 ;;; Implementation output.
384 (defvar *instance-class*)
386 (defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer)
387 (sequence-output (stream sequencer)
392 (class :direct-methods :start) (class :direct-methods :end)
393 (class :effective-methods)
394 (class :vtables :start) (class :vtables :end)
395 (class :object :prepare) (class :object :start) (class :object :end)
399 (banner (format nil "Class ~A" class) stream))
401 ((class :object :start)
403 /* The class object. */
404 const struct ~A ~A__classobj = {~%"
405 (ilayout-struct-tag (sod-class-metaclass class))
407 ((class :object :end)
408 (format stream "};~2%")))
410 (let ((*instance-class* class))
411 (hook-output (sod-class-ilayout (sod-class-metaclass class))
415 ;;;--------------------------------------------------------------------------
416 ;;; Direct and effective methods.
418 (defmethod hook-output progn ((method delegating-direct-method)
421 (with-slots (class body) method
423 (return-from hook-output))
424 (sequence-output (stream sequencer)
425 ((class :direct-method method :start)
426 (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
427 (mapcar #'argument-name
428 (c-function-arguments (sod-method-next-method-type
430 ((class :direct-method method :end)
431 (format stream "#undef CALL_NEXT_METHOD~%")))))
433 (defmethod hook-output progn ((method sod-method)
436 (with-slots (class body) method
438 (return-from hook-output))
439 (sequence-output (stream sequencer)
440 :constraint ((class :direct-methods :start)
441 (class :direct-method method :start)
442 (class :direct-method method :body)
443 (class :direct-method method :end)
444 (class :direct-methods :end))
445 ((class :direct-method method :body)
446 (pprint-c-type (sod-method-function-type method)
448 (sod-method-function-name method))
449 (format stream "~&{~%")
450 (write body :stream stream :pretty nil :escape nil)
451 (format stream "~&}~%"))
452 ((class :direct-method method :end)
455 (defmethod hook-output progn ((method basic-effective-method)
458 (with-slots (class functions) method
459 (sequence-output (stream sequencer)
460 ((class :effective-methods)
461 (dolist (func functions)
462 (write func :stream stream :escape nil :circle nil))))))
464 ;;;--------------------------------------------------------------------------
467 (defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer)
468 (with-slots (class chain-head chain-tail) vtable
469 (sequence-output (stream sequencer)
470 :constraint ((class :vtables :start)
471 (class :vtable chain-head :start)
472 (class :vtable chain-head :end)
473 (class :vtables :end))
474 ((class :vtable chain-head :start)
475 (format stream "/* Vtable for ~A chain. */~@
476 const struct ~A ~A = {~%"
478 (vtable-struct-tag chain-tail chain-head)
479 (vtable-name class chain-head)))
480 ((class :vtable chain-head :end)
481 (format stream "};~2%")))))
483 (defmethod hook-output progn ((cptr class-pointer)
486 (with-slots (class chain-head metaclass meta-chain-head) cptr
487 (sequence-output (stream sequencer)
488 :constraint ((class :vtable chain-head :start)
489 (class :vtable chain-head :class-pointer metaclass)
490 (class :vtable chain-head :end))
491 ((class :vtable chain-head :class-pointer metaclass)
492 (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%"
493 (if (sod-class-direct-superclasses meta-chain-head)
494 (format nil "_cls_~A"
495 (sod-class-nickname meta-chain-head))
498 (sod-class-nickname meta-chain-head)
499 (sod-class-nickname metaclass))))))
501 (defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer)
502 (with-slots (class chain-head) boff
503 (sequence-output (stream sequencer)
504 :constraint ((class :vtable chain-head :start)
505 (class :vtable chain-head :base-offset)
506 (class :vtable chain-head :end))
507 ((class :vtable chain-head :base-offset)
508 (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%"
510 (ilayout-struct-tag class)
511 (sod-class-nickname chain-head))))))
513 (defmethod hook-output progn ((choff chain-offset)
516 (with-slots (class chain-head target-head) choff
517 (sequence-output (stream sequencer)
518 :constraint ((class :vtable chain-head :start)
519 (class :vtable chain-head :chain-offset target-head)
520 (class :vtable chain-head :end))
521 ((class :vtable chain-head :chain-offset target-head)
522 (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
523 (format nil "_off_~A" (sod-class-nickname target-head))
524 (ilayout-struct-tag class)
525 (sod-class-nickname chain-head)
526 (sod-class-nickname target-head))))))
528 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
529 (with-slots (class subclass chain-head) vtmsgs
530 (sequence-output (stream sequencer)
531 :constraint ((subclass :vtable chain-head :start)
532 (subclass :vtable chain-head :vtmsgs class :start)
533 (subclass :vtable chain-head :vtmsgs class :slots)
534 (subclass :vtable chain-head :vtmsgs class :end)
535 (subclass :vtable chain-head :end))
536 ((subclass :vtable chain-head :vtmsgs class :start)
537 (format stream " { /* Method entries for ~A messages. */~%"
539 ((subclass :vtable chain-head :vtmsgs class :end)
540 (format stream " },~%")))))
542 (defmethod hook-output progn ((entry method-entry)
545 (with-slots (method chain-head chain-tail) entry
546 (let* ((message (effective-method-message method))
547 (class (effective-method-class method))
548 (super (sod-message-class message)))
549 (sequence-output (stream sequencer)
550 ((class :vtable chain-head :vtmsgs super :slots)
551 (format stream " /* ~19@A = */ ~A,~%"
552 (sod-message-name message)
553 (method-entry-function-name method chain-head)))))))
555 ;;;--------------------------------------------------------------------------
556 ;;; Filling in the class object.
558 (defmethod hook-output progn ((ichain ichain)
559 (reason (eql 'class))
561 (with-slots (class chain-head) ichain
562 (sequence-output (stream sequencer)
563 :constraint ((*instance-class* :object :start)
564 (*instance-class* :object chain-head :ichain :start)
565 (*instance-class* :object chain-head :ichain :end)
566 (*instance-class* :object :end))
567 ((*instance-class* :object chain-head :ichain :start)
568 (format stream " { { /* ~A ichain */~%"
569 (sod-class-nickname chain-head)))
570 ((*instance-class* :object chain-head :ichain :end)
571 (format stream " } },~%")))))
573 (defmethod hook-output progn ((islots islots)
574 (reason (eql 'class))
576 (with-slots (class) islots
577 (let ((chain-head (sod-class-chain-head class)))
578 (sequence-output (stream sequencer)
579 :constraint ((*instance-class* :object chain-head :ichain :start)
580 (*instance-class* :object class :slots :start)
581 (*instance-class* :object class :slots)
582 (*instance-class* :object class :slots :end)
583 (*instance-class* :object chain-head :ichain :end))
584 ((*instance-class* :object class :slots :start)
585 (format stream " { /* Class ~A */~%" class))
586 ((*instance-class* :object class :slots :end)
587 (format stream " },~%"))))))
589 (defmethod hook-output progn ((vtptr vtable-pointer)
590 (reason (eql 'class))
592 (with-slots (class chain-head chain-tail) vtptr
593 (sequence-output (stream sequencer)
594 :constraint ((*instance-class* :object chain-head :ichain :start)
595 (*instance-class* :object chain-head :vtable)
596 (*instance-class* :object chain-head :ichain :end))
597 ((*instance-class* :object chain-head :vtable)
598 (format stream " &~A__vtable_~A,~%"
599 class (sod-class-nickname chain-head))))))
601 (defgeneric find-class-initializer (slot class)
602 (:method ((slot effective-slot) (class sod-class))
603 (let ((dslot (effective-slot-direct-slot slot)))
604 (or (some (lambda (super)
605 (find dslot (sod-class-class-initializers super)
606 :test #'sod-initializer-slot))
607 (sod-class-precedence-list class))
608 (effective-slot-initializer slot)))))
610 (defgeneric output-class-initializer (slot instance stream)
611 (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
612 (let ((func (effective-slot-initializer-function slot))
613 (direct-slot (effective-slot-direct-slot slot)))
615 (format stream " /* ~15@A = */ ~A,~%"
616 (sod-slot-name direct-slot)
617 (funcall func instance))
618 (call-next-method))))
619 (:method ((slot effective-slot) (instance sod-class) stream)
620 (let ((init (find-class-initializer slot instance))
621 (direct-slot (effective-slot-direct-slot slot)))
622 (ecase (sod-initializer-value-kind init)
623 (:simple (format stream " /* ~15@A = */ ~A,~%"
624 (sod-slot-name direct-slot)
625 (sod-initializer-value-form init)))
626 (:compound (format stream " /* ~15@A = */ ~@<{ ~;~A~; },~:>~%"
627 (sod-slot-name direct-slot)
628 (sod-initializer-value-form init)))))))
630 (defmethod hook-output progn ((slot sod-class-effective-slot)
631 (reason (eql 'class))
633 (let ((instance *instance-class*)
634 (func (effective-slot-prepare-function slot)))
636 (sequence-output (stream sequencer)
637 ((instance :object :prepare)
638 (funcall func instance stream))))))
640 (defmethod hook-output progn ((slot effective-slot)
641 (reason (eql 'class))
643 (with-slots (class (dslot slot)) slot
644 (let ((instance *instance-class*)
645 (super (sod-slot-class dslot)))
646 (sequence-output (stream sequencer)
647 ((instance :object super :slots)
648 (output-class-initializer slot instance stream))))))
650 ;;;----- That's all, folks --------------------------------------------------