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 (defmacro sequence-output
32 ((streamvar sequencer) &body clauses)
33 (let ((seqvar (gensym "SEQ")))
34 (labels ((convert-item-name (name)
38 (convert-constraint (constraint)
39 (cons 'list (mapcar #'convert-item-name constraint)))
40 (process-body (clauses)
41 (if (eq (car clauses) :constraint)
42 (cons `(add-sequencer-constraint
44 ,(convert-constraint (cadr clauses)))
45 (process-body (cddr clauses)))
46 (mapcar (lambda (clause)
47 (let ((name (car clause))
49 `(add-sequencer-item-function
51 ,(convert-item-name name)
55 `(let ((,seqvar ,sequencer))
56 ,@(process-body clauses)))))
58 ;;;--------------------------------------------------------------------------
61 (defmethod add-output-hooks progn
62 ((class sod-class) (reason (eql :h)) sequencer)
64 ;; Main output sequencing.
65 (sequence-output (stream sequencer)
73 (class :islots :start) (class :islots :slots) (class :islots :end)
74 (class :vtmsgs :start) (class :vtmsgs :end)
75 (class :vtables :start) (class :vtables :end)
76 (class :vtable-externs) (class :vtable-externs-after)
77 (class :direct-methods)
78 (class :ichains :start) (class :ichains :end)
79 (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
84 (format stream "typedef struct ~A ~A;~%"
85 (ichain-struct-tag class (sod-class-chain-head class)) class))
88 (banner (format nil "Class ~A" class) stream))
89 ((class :vtable-externs-after)
92 ;; Maybe generate an islots structure.
93 (when (sod-class-slots class)
94 (dolist (slot (sod-class-slots class))
95 (add-output-hooks slot 'populate-islots sequencer))
96 (sequence-output (stream sequencer)
97 ((class :islots :start)
98 (format stream "struct ~A {~%" (islots-struct-tag class)))
100 (format stream "};~2%"))))
102 ;; Declare the direct methods.
103 (when (sod-class-methods class)
104 (dolist (method (sod-class-methods class))
105 (add-output-hooks method :declare-direct-methods sequencer))
106 (sequence-output (stream sequencer)
107 ((class :direct-methods)
110 ;; Provide upcast macros which do the right thing.
111 (when (sod-class-direct-superclasses class)
112 (sequence-output (stream sequencer)
113 ((class :conversions)
114 (let ((chain-head (sod-class-chain-head class)))
115 (dolist (super (cdr (sod-class-precedence-list class)))
116 (let ((super-head (sod-class-chain-head super)))
117 (format stream (concatenate 'string "#define "
118 "~:@(~A__CONV_~A~)(p) ((~A *)"
119 "~:[SOD_XCHAIN(~A, p)~;p~])~%")
120 class (sod-class-nickname super) super
121 (eq chain-head super-head)
122 (sod-class-nickname super-head))))))))
124 ;; Generate vtmsgs structure for all superclasses.
125 (add-output-hooks (car (sod-class-vtables class))
129 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)
130 (with-slots (ilayout vtables) class
131 (add-output-hooks ilayout reason sequencer)
132 (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
134 ;;;--------------------------------------------------------------------------
135 ;;; Instance structure.
137 (defmethod add-output-hooks progn
138 ((slot sod-slot) (reason (eql 'populate-islots)) sequencer)
139 (sequence-output (stream sequencer)
140 (((sod-slot-class slot) :islots :slots)
141 (pprint-logical-block (stream nil :prefix " " :suffix ";")
142 (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
145 (defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer)
146 (with-slots (ichains) ilayout
147 (dolist (ichain ichains) (add-output-hooks ichain reason sequencer))))
149 (defmethod add-output-hooks progn
150 ((ilayout ilayout) (reason (eql :h)) sequencer)
151 (with-slots (class ichains) ilayout
152 (sequence-output (stream sequencer)
153 ((class :ilayout :start)
154 (format stream "struct ~A {~%" (ilayout-struct-tag class)))
155 ((class :ilayout :end)
156 (format stream "};~2%")))
157 (dolist (ichain ichains)
158 (add-output-hooks ichain 'populate-ilayout sequencer))))
160 (defmethod add-output-hooks progn
161 ((ichain ichain) (reason (eql :h)) sequencer)
162 (with-slots (class chain-head) ichain
163 (sequence-output (stream sequencer)
164 :constraint ((class :ichains :start)
165 (class :ichain chain-head :start)
166 (class :ichain chain-head :slots)
167 (class :ichain chain-head :end)
168 (class :ichains :end))
169 ((class :ichain chain-head :start)
170 (format stream "struct ~A {~%" (ichain-struct-tag class chain-head)))
171 ((class :ichain chain-head :end)
172 (format stream "};~2%")))))
174 (defmethod add-output-hooks progn
175 ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
176 (with-slots (class chain-head) ichain
177 (sequence-output (stream sequencer)
178 ((class :ilayout :slots)
179 (format stream " struct ~A ~A;~%"
180 (ichain-struct-tag class chain-head)
181 (sod-class-nickname chain-head))))))
183 (defmethod add-output-hooks progn ((ichain ichain) reason sequencer)
184 (with-slots (body) ichain
185 (dolist (item body) (add-output-hooks item reason sequencer))))
187 (defmethod add-output-hooks progn
188 ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
189 (with-slots (class chain-head) vtptr
190 (sequence-output (stream sequencer)
191 ((class :ichain chain-head :slots)
192 (format stream " const struct ~A *_vt;~%"
193 (vtable-struct-tag class chain-head))))))
195 (defmethod add-output-hooks progn
196 ((islots islots) (reason (eql :h)) sequencer)
197 (with-slots (class subclass slots) islots
198 (sequence-output (stream sequencer)
199 ((subclass :ichain (sod-class-chain-head class) :slots)
200 (format stream " struct ~A ~A;~%"
201 (islots-struct-tag class)
202 (sod-class-nickname class))))))
204 ;;;--------------------------------------------------------------------------
205 ;;; Vtable structure.
207 (defmethod add-output-hooks progn ((vtable vtable) reason sequencer)
208 (with-slots (body) vtable
209 (dolist (item body) (add-output-hooks item reason sequencer))))
211 (defmethod add-output-hooks progn
212 ((vtable vtable) (reason (eql :h)) sequencer)
213 (with-slots (class chain-head) vtable
214 (sequence-output (stream sequencer)
215 :constraint ((class :vtables :start)
216 (class :vtable chain-head :start)
217 (class :vtable chain-head :slots)
218 (class :vtable chain-head :end)
219 (class :vtables :end))
220 ((class :vtable chain-head :start)
221 (format stream "struct ~A {~%" (vtable-struct-tag class chain-head)))
222 ((class :vtable chain-head :end)
223 (format stream "};~2%"))
224 ((class :vtable-externs)
225 (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
226 (vtable-struct-tag class chain-head)
227 class (sod-class-nickname chain-head))))))
229 (defmethod add-output-hooks progn
230 ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
231 (with-slots (class subclass chain-head) vtmsgs
232 (sequence-output (stream sequencer)
233 ((subclass :vtable chain-head :slots)
234 (format stream " struct ~A ~A;~%"
235 (vtmsgs-struct-tag subclass class)
236 (sod-class-nickname class))))))
238 (defmethod add-output-hooks progn
239 ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer)
240 (when (vtmsgs-entries vtmsgs)
241 (with-slots (class subclass) vtmsgs
242 (sequence-output (stream sequencer)
243 :constraint ((subclass :vtmsgs :start)
244 (subclass :vtmsgs class :start)
245 (subclass :vtmsgs class :slots)
246 (subclass :vtmsgs class :end)
247 (subclass :vtmsgs :end))
248 ((subclass :vtmsgs class :start)
249 (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class)))
250 ((subclass :vtmsgs class :end)
251 (format stream "};~2%"))))))
253 (defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer)
254 (with-slots (entries) vtmsgs
255 (dolist (entry entries) (add-output-hooks entry reason sequencer))))
257 (defmethod add-output-hooks progn ((entry method-entry) reason sequencer)
258 (with-slots (method) entry
259 (add-output-hooks method reason sequencer)))
261 (defmethod add-output-hooks progn
262 ((method effective-method) (reason (eql 'populate-vtmsgs)) sequencer)
263 (let* ((message (effective-method-message method))
264 (class (effective-method-class method))
265 (class-type (find-class-type (sod-class-name class)))
266 (raw-type (sod-message-type message))
267 (type (c-type (* (fun (lisp (c-type-subtype raw-type))
268 ("/*me*/" (* (lisp class-type)))
269 . (commentify-argument-names
270 (c-function-arguments raw-type)))))))
271 (sequence-output (stream sequencer)
272 ((class :vtmsgs (sod-message-class message) :slots)
273 (pprint-logical-block (stream nil :prefix " " :suffix ";")
274 (pprint-c-type type stream (sod-message-name message)))
277 (defmethod add-output-hooks progn
278 ((cptr class-pointer) (reason (eql :h)) sequencer)
279 (with-slots (class chain-head metaclass meta-chain-head) cptr
280 (sequence-output (stream sequencer)
281 ((class :vtable chain-head :slots)
282 (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
284 (if (sod-class-direct-superclasses meta-chain-head)
285 (sod-class-nickname meta-chain-head)
288 (defmethod add-output-hooks progn
289 ((boff base-offset) (reason (eql :h)) sequencer)
290 (with-slots (class chain-head) boff
291 (sequence-output (stream sequencer)
292 ((class :vtable chain-head :slots)
293 (write-line " size_t _base;" stream)))))
295 (defmethod add-output-hooks progn
296 ((choff chain-offset) (reason (eql :h)) sequencer)
297 (with-slots (class chain-head target-head) choff
298 (sequence-output (stream sequencer)
299 ((class :vtable chain-head :slots)
300 (format stream " ptrdiff_t _off_~A;~%"
301 (sod-class-nickname target-head))))))
303 ;;;--------------------------------------------------------------------------
308 (let ((sequencer (make-instance 'sequencer))
309 (class (find-sod-class name)))
310 (add-output-hooks class :h sequencer)
311 (invoke-sequencer-items sequencer *standard-output*)
314 ;;;----- That's all, folks --------------------------------------------------