3 ;;; Output functions for classes
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
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))
34 ;; Main output sequencing.
35 (sequence-output (stream sequencer)
40 (class :islots :start) (class :islots :slots) (class :islots :end)
41 (class :vtmsgs :start) (class :vtmsgs :end)
42 (class :vtables :start) (class :vtables :end)
43 (class :vtable-externs) (class :vtable-externs-after)
44 (class :methods :start) (class :methods) (class :methods :end)
45 (class :ichains :start) (class :ichains :end)
46 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
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 ;; Generate vtmsgs structure for all superclasses.
109 (hook-output (car (sod-class-vtables class))
113 (defmethod hook-output progn ((class sod-class) reason sequencer)
114 (with-slots (ilayout vtables methods effective-methods) class
115 (hook-output ilayout reason sequencer)
116 (dolist (method methods) (hook-output method reason sequencer))
117 (dolist (method effective-methods)
118 (hook-output method reason sequencer))
119 (dolist (vtable vtables) (hook-output vtable reason sequencer))))
121 ;;;--------------------------------------------------------------------------
122 ;;; Instance structure.
124 (defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
126 (sequence-output (stream sequencer)
127 (((sod-slot-class slot) :islots :slots)
128 (pprint-logical-block (stream nil :prefix " " :suffix ";")
129 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
132 (defmethod hook-output progn ((ilayout ilayout) reason sequencer)
133 (with-slots (ichains) ilayout
134 (dolist (ichain ichains) (hook-output ichain reason sequencer))))
136 (defmethod hook-output progn ((ichain ichain) reason sequencer)
137 (dolist (item (ichain-body ichain))
138 (hook-output item reason sequencer)))
140 (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
142 (with-slots (class ichains) ilayout
143 (sequence-output (stream sequencer)
144 ((class :ilayout :start)
145 (format stream "/* Instance layout. */~@
147 (ilayout-struct-tag class)))
148 ((class :ilayout :end)
149 (format stream "};~2%")))
150 (dolist (ichain ichains)
151 (hook-output ichain 'ilayout sequencer))))
153 (defmethod hook-output progn ((ichain ichain) (reason (eql :h))
155 (with-slots (class chain-head chain-tail) ichain
156 (when (eq class chain-tail)
157 (sequence-output (stream sequencer)
158 :constraint ((class :ichains :start)
159 (class :ichain chain-head :start)
160 (class :ichain chain-head :slots)
161 (class :ichain chain-head :end)
162 (class :ichains :end))
163 ((class :ichain chain-head :start)
164 (format stream "/* Instance chain structure. */~@
166 (ichain-struct-tag chain-tail chain-head)))
167 ((class :ichain chain-head :end)
168 (format stream "};~2%")
169 (format stream "/* Union of equivalent superclass chains. */~@
171 ~:{ struct ~A ~A;~%~}~
173 (ichain-union-tag chain-tail chain-head)
175 ;; Make sure the most specific class is first: only the
176 ;; first element of a union can be statically initialized in
178 (mapcar (lambda (super)
179 (list (ichain-struct-tag super chain-head)
180 (sod-class-nickname super)))
181 (sod-class-chain chain-tail))))))))
183 (defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
185 (with-slots (class chain-head chain-tail) ichain
186 (sequence-output (stream sequencer)
187 ((class :ilayout :slots)
188 (format stream " union ~A ~A;~%"
189 (ichain-union-tag chain-tail chain-head)
190 (sod-class-nickname chain-head))))))
192 (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
194 (with-slots (class chain-head chain-tail) vtptr
195 (sequence-output (stream sequencer)
196 ((class :ichain chain-head :slots)
197 (format stream " const struct ~A *_vt;~%"
198 (vtable-struct-tag chain-tail chain-head))))))
200 (defmethod hook-output progn ((islots islots) reason sequencer)
201 (dolist (slot (islots-slots islots))
202 (hook-output slot reason sequencer)))
204 (defmethod hook-output progn ((islots islots) (reason (eql :h))
206 (with-slots (class subclass slots) islots
207 (sequence-output (stream sequencer)
208 ((subclass :ichain (sod-class-chain-head class) :slots)
209 (format stream " struct ~A ~A;~%"
210 (islots-struct-tag class)
211 (sod-class-nickname class))))))
213 ;;;--------------------------------------------------------------------------
214 ;;; Vtable structure.
216 (defmethod hook-output progn ((vtable vtable) reason sequencer)
217 (with-slots (body) vtable
218 (dolist (item body) (hook-output item reason sequencer))))
220 (defmethod hook-output progn ((method sod-method) (reason (eql :h))
222 (with-slots (class) method
223 (sequence-output (stream sequencer)
225 (let ((type (sod-method-function-type method)))
226 (princ "extern " stream)
227 (pprint-c-type (commentify-function-type type) stream
228 (sod-method-function-name method))
229 (format stream ";~%"))))))
231 (defmethod hook-output progn ((vtable vtable) (reason (eql :h))
233 (with-slots (class chain-head chain-tail) vtable
234 (when (eq class chain-tail)
235 (sequence-output (stream sequencer)
236 :constraint ((class :vtables :start)
237 (class :vtable chain-head :start)
238 (class :vtable chain-head :slots)
239 (class :vtable chain-head :end)
240 (class :vtables :end))
241 ((class :vtable chain-head :start)
242 (format stream "/* Vtable structure. */~@
244 (vtable-struct-tag chain-tail chain-head)))
245 ((class :vtable chain-head :end)
246 (format stream "};~2%"))))
247 (sequence-output (stream sequencer)
248 ((class :vtable-externs)
249 (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
250 (vtable-struct-tag chain-tail chain-head)
251 class (sod-class-nickname chain-head))))))
253 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
255 (with-slots (class subclass chain-head chain-tail) vtmsgs
256 (sequence-output (stream sequencer)
257 ((subclass :vtable chain-head :slots)
258 (format stream " struct ~A ~A;~%"
259 (vtmsgs-struct-tag subclass class)
260 (sod-class-nickname class))))))
262 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
264 (when (vtmsgs-entries vtmsgs)
265 (with-slots (class subclass) vtmsgs
266 (sequence-output (stream sequencer)
267 :constraint ((subclass :vtmsgs :start)
268 (subclass :vtmsgs class :start)
269 (subclass :vtmsgs class :slots)
270 (subclass :vtmsgs class :end)
271 (subclass :vtmsgs :end))
272 ((subclass :vtmsgs class :start)
273 (format stream "/* Messages protocol from class ~A */~@
276 (vtmsgs-struct-tag subclass class)))
277 ((subclass :vtmsgs class :end)
278 (format stream "};~2%"))))))
280 (defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
281 (with-slots (entries) vtmsgs
282 (dolist (entry entries) (hook-output entry reason sequencer))))
284 (defmethod hook-output progn ((entry method-entry) reason sequencer)
285 (with-slots (method) entry
286 (hook-output method reason sequencer)))
288 (defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
290 (let* ((method (method-entry-effective-method entry))
291 (message (effective-method-message method))
292 (class (effective-method-class method))
293 (type (method-entry-function-type entry))
294 (commented-type (commentify-function-type type)))
295 (sequence-output (stream sequencer)
296 ((class :vtmsgs (sod-message-class message) :slots)
297 (pprint-logical-block (stream nil :prefix " " :suffix ";")
298 (pprint-c-type commented-type stream (sod-message-name message)))
301 (defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
303 (with-slots (class chain-head metaclass meta-chain-head) cptr
304 (sequence-output (stream sequencer)
305 ((class :vtable chain-head :slots)
306 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
308 (if (sod-class-direct-superclasses meta-chain-head)
309 (sod-class-nickname meta-chain-head)
312 (defmethod hook-output progn ((boff base-offset) (reason (eql :h))
314 (with-slots (class chain-head) boff
315 (sequence-output (stream sequencer)
316 ((class :vtable chain-head :slots)
317 (write-line " size_t _base;" stream)))))
319 (defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
321 (with-slots (class chain-head target-head) choff
322 (sequence-output (stream sequencer)
323 ((class :vtable chain-head :slots)
324 (format stream " ptrdiff_t _off_~A;~%"
325 (sod-class-nickname target-head))))))
327 ;;;--------------------------------------------------------------------------
328 ;;; Implementation output.
330 (defvar *instance-class*)
332 (defmethod hook-output progn ((class sod-class) (reason (eql :c))
334 (sequence-output (stream sequencer)
339 (class :direct-methods :start) (class :direct-methods :end)
340 (class :effective-methods)
341 (class :vtables :start) (class :vtables :end)
342 (class :object :prepare) (class :object :start) (class :object :end)
346 (banner (format nil "Class ~A" class) stream))
348 ((class :object :start)
350 /* The class object. */
351 const struct ~A ~A__classobj = {~%"
352 (ilayout-struct-tag (sod-class-metaclass class))
354 ((class :object :end)
355 (format stream "};~2%")))
357 (let ((*instance-class* class))
358 (hook-output (sod-class-ilayout (sod-class-metaclass class))
362 ;;;--------------------------------------------------------------------------
365 (defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
367 (with-slots (class body) method
369 (return-from hook-output))
370 (sequence-output (stream sequencer)
371 ((class :direct-method method :start)
372 (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
373 (mapcar #'argument-name
374 (c-function-arguments (sod-method-next-method-type
376 ((class :direct-method method :end)
377 (format stream "#undef CALL_NEXT_METHOD~%")))))
379 (defmethod hook-output progn ((method sod-method) (reason (eql :c))
381 (with-slots (class body) method
383 (return-from hook-output))
384 (sequence-output (stream sequencer)
385 :constraint ((class :direct-methods :start)
386 (class :direct-method method :start)
387 (class :direct-method method :body)
388 (class :direct-method method :end)
389 (class :direct-methods :end))
390 ((class :direct-method method :body)
391 (pprint-c-type (sod-method-function-type method)
393 (sod-method-function-name method))
394 (format stream "~&{~%")
395 (write body :stream stream :pretty nil :escape nil)
396 (format stream "~&}~%"))
397 ((class :direct-method method :end)
400 ;;;--------------------------------------------------------------------------
403 (defmethod hook-output progn ((vtable vtable) (reason (eql :c))
405 (with-slots (class chain-head chain-tail) vtable
406 (sequence-output (stream sequencer)
407 :constraint ((class :vtables :start)
408 (class :vtable chain-head :start)
409 (class :vtable chain-head :end)
410 (class :vtables :end))
411 ((class :vtable chain-head :start)
412 (format stream "/* Vtable for ~A chain. */~@
413 static const struct ~A ~A = {~%"
415 (vtable-struct-tag chain-tail chain-head)
416 (vtable-name chain-tail chain-head)))
417 ((class :vtable chain-head :end)
418 (format stream "};~2%")))))
420 (defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
422 (with-slots (class chain-head metaclass meta-chain-head) cptr
423 (sequence-output (stream sequencer)
424 :constraint ((class :vtable chain-head :start)
425 (class :vtable chain-head :class-pointer metaclass)
426 (class :vtable chain-head :end))
427 ((class :vtable chain-head :class-pointer metaclass)
428 (format stream " &~A__classobj.~A.~A,~%"
429 (sod-class-metaclass class)
430 (sod-class-nickname meta-chain-head)
431 (sod-class-nickname metaclass))))))
433 (defmethod hook-output progn ((boff base-offset) (reason (eql :c))
435 (with-slots (class chain-head) boff
436 (sequence-output (stream sequencer)
437 :constraint ((class :vtable chain-head :start)
438 (class :vtable chain-head :base-offset)
439 (class :vtable chain-head :end))
440 ((class :vtable chain-head :base-offset)
441 (format stream " offsetof(struct ~A, ~A),~%"
442 (ilayout-struct-tag class)
443 (sod-class-nickname chain-head))))))
445 (defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
447 (with-slots (class chain-head target-head) choff
448 (sequence-output (stream sequencer)
449 :constraint ((class :vtable chain-head :start)
450 (class :vtable chain-head :chain-offset target-head)
451 (class :vtable chain-head :end))
452 ((class :vtable chain-head :chain-offset target-head)
453 (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
454 (ilayout-struct-tag class)
455 (sod-class-nickname chain-head)
456 (sod-class-nickname target-head))))))
458 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
460 (with-slots (class subclass chain-head) vtmsgs
461 (sequence-output (stream sequencer)
462 :constraint ((subclass :vtable chain-head :start)
463 (subclass :vtable chain-head :vtmsgs class :start)
464 (subclass :vtable chain-head :vtmsgs class :slots)
465 (subclass :vtable chain-head :vtmsgs class :end)
466 (subclass :vtable chain-head :end))
467 ((subclass :vtable chain-head :vtmsgs class :start)
468 (format stream " { /* Method entries for ~A messages. */~%"
470 ((subclass :vtable chain-head :vtmsgs class :end)
471 (format stream " },~%")))))
473 (defmethod hook-output progn ((entry method-entry) (reason (eql :c))
475 (with-slots (method chain-head chain-tail) entry
476 (let* ((message (effective-method-message method))
477 (class (effective-method-class method))
478 (super (sod-message-class message)))
479 (sequence-output (stream sequencer)
480 ((class :vtable chain-head :vtmsgs super :slots)
481 (format stream " ~A,~%"
482 (method-entry-function-name method chain-head)))))))
484 ;;;--------------------------------------------------------------------------
485 ;;; Filling in the class object.
487 (defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
489 (with-slots (class chain-head) ichain
490 (sequence-output (stream sequencer)
491 :constraint ((*instance-class* :object :start)
492 (*instance-class* :object chain-head :ichain :start)
493 (*instance-class* :object chain-head :ichain :end)
494 (*instance-class* :object :end))
495 ((*instance-class* :object chain-head :ichain :start)
496 (format stream " { { /* ~A ichain */~%"
497 (sod-class-nickname chain-head)))
498 ((*instance-class* :object chain-head :ichain :end)
499 (format stream " } },~%")))))
501 (defmethod hook-output progn ((islots islots) (reason (eql 'class))
503 (with-slots (class) islots
504 (let ((chain-head (sod-class-chain-head class)))
505 (sequence-output (stream sequencer)
506 :constraint ((*instance-class* :object chain-head :ichain :start)
507 (*instance-class* :object class :slots :start)
508 (*instance-class* :object class :slots)
509 (*instance-class* :object class :slots :end)
510 (*instance-class* :object chain-head :ichain :end))
511 ((*instance-class* :object class :slots :start)
512 (format stream " { /* Class ~A */~%" class))
513 ((*instance-class* :object class :slots :end)
514 (format stream " },~%"))))))
516 (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
518 (with-slots (class chain-head chain-tail) vtptr
519 (sequence-output (stream sequencer)
520 :constraint ((*instance-class* :object chain-head :ichain :start)
521 (*instance-class* :object chain-head :vtable)
522 (*instance-class* :object chain-head :ichain :end))
523 ((*instance-class* :object chain-head :vtable)
524 (format stream " &~A__vtable_~A,~%"
525 class (sod-class-nickname chain-head))))))
527 (defgeneric find-class-initializer (slot class)
528 (:method ((slot effective-slot) (class sod-class))
529 (let ((dslot (effective-slot-direct-slot slot)))
530 (or (some (lambda (super)
531 (find dslot (sod-class-class-initializers super)
532 :test #'sod-initializer-slot))
533 (sod-class-precedence-list class))
534 (effective-slot-initializer slot)))))
536 (defgeneric output-class-initializer (slot instance stream)
537 (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
538 (let ((func (effective-slot-initializer-function slot)))
540 (format stream " ~A,~%" (funcall func instance))
541 (call-next-method))))
542 (:method ((slot effective-slot) (instance sod-class) stream)
543 (let ((init (find-class-initializer slot instance)))
544 (ecase (sod-initializer-value-kind init)
545 (:simple (format stream " ~A,~%"
546 (sod-initializer-value-form init)))
547 (:compound (format stream " ~@<{ ~;~A~; },~:>~%"
548 (sod-initializer-value-form init)))))))
550 (defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
552 (let ((instance *instance-class*)
553 (func (effective-slot-prepare-function slot)))
555 (sequence-output (stream sequencer)
556 ((instance :object :prepare)
557 (funcall func instance stream))))))
559 (defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
561 (with-slots (class (dslot slot)) slot
562 (let ((instance *instance-class*)
563 (super (sod-slot-class dslot)))
564 (sequence-output (stream sequencer)
565 ((instance :object super :slots)
566 (output-class-initializer slot instance stream))))))
568 ;;;--------------------------------------------------------------------------
573 (let ((sequencer (make-instance 'sequencer))
574 (class (find-sod-class name)))
575 (hook-output class :h sequencer)
576 (invoke-sequencer-items sequencer *standard-output*)
579 ;;;----- That's all, folks --------------------------------------------------