Commit | Line | Data |
---|---|---|
1f1d88f5 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Output functions for classes | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
11 | ;;; | |
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. | |
16 | ;;; | |
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. | |
21 | ;;; | |
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. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Utility macro. | |
30 | ||
31 | (defmacro sequence-output | |
32 | ((streamvar sequencer) &body clauses) | |
33 | (let ((seqvar (gensym "SEQ"))) | |
34 | (labels ((convert-item-name (name) | |
35 | (if (listp name) | |
36 | (cons 'list name) | |
37 | 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 | |
43 | ,seqvar | |
44 | ,(convert-constraint (cadr clauses))) | |
45 | (process-body (cddr clauses))) | |
46 | (mapcar (lambda (clause) | |
47 | (let ((name (car clause)) | |
48 | (body (cdr clause))) | |
49 | `(add-sequencer-item-function | |
50 | ,seqvar | |
51 | ,(convert-item-name name) | |
52 | (lambda (,streamvar) | |
53 | ,@body)))) | |
54 | clauses)))) | |
55 | `(let ((,seqvar ,sequencer)) | |
56 | ,@(process-body clauses))))) | |
57 | ||
58 | ;;;-------------------------------------------------------------------------- | |
59 | ;;; Classes. | |
60 | ||
61 | (defmethod add-output-hooks progn | |
62 | ((class sod-class) (reason (eql :h)) sequencer) | |
63 | ||
64 | ;; Main output sequencing. | |
65 | (sequence-output (stream sequencer) | |
66 | ||
67 | :constraint | |
68 | (:typedefs) | |
69 | ||
70 | :constraint | |
71 | ((:classes :start) | |
72 | (class :banner) | |
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) | |
80 | (class :conversions) | |
81 | (:classes :end)) | |
82 | ||
83 | (:typedefs | |
84 | (format stream "typedef struct ~A ~A;~%" | |
85 | (ichain-struct-tag class (sod-class-chain-head class)) class)) | |
86 | ||
87 | ((class :banner) | |
88 | (banner (format nil "Class ~A" class) stream)) | |
89 | ((class :vtable-externs-after) | |
90 | (terpri stream))) | |
91 | ||
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))) | |
99 | ((class :islots :end) | |
100 | (format stream "};~2%")))) | |
101 | ||
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) | |
108 | (terpri stream)))) | |
109 | ||
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)))))))) | |
123 | ||
124 | ;; Generate vtmsgs structure for all superclasses. | |
125 | (add-output-hooks (car (sod-class-vtables class)) | |
126 | 'populate-vtmsgs | |
127 | sequencer)) | |
128 | ||
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)))) | |
133 | ||
134 | ;;;-------------------------------------------------------------------------- | |
135 | ;;; Instance structure. | |
136 | ||
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))) | |
143 | (terpri stream)))) | |
144 | ||
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)))) | |
148 | ||
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)))) | |
159 | ||
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%"))))) | |
173 | ||
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)))))) | |
182 | ||
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)))) | |
186 | ||
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)))))) | |
194 | ||
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)))))) | |
203 | ||
204 | ;;;-------------------------------------------------------------------------- | |
205 | ;;; Vtable structure. | |
206 | ||
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)))) | |
210 | ||
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)))))) | |
228 | ||
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)))))) | |
237 | ||
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%")))))) | |
252 | ||
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)))) | |
256 | ||
257 | (defmethod add-output-hooks progn ((entry method-entry) reason sequencer) | |
258 | (with-slots (method) entry | |
259 | (add-output-hooks method reason sequencer))) | |
260 | ||
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))) | |
275 | (terpri stream))))) | |
276 | ||
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~];~%" | |
283 | metaclass | |
284 | (if (sod-class-direct-superclasses meta-chain-head) | |
285 | (sod-class-nickname meta-chain-head) | |
286 | nil)))))) | |
287 | ||
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))))) | |
294 | ||
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)))))) | |
302 | ||
303 | ;;;-------------------------------------------------------------------------- | |
304 | ;;; Testing. | |
305 | ||
306 | #+test | |
307 | (defun test (name) | |
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*) | |
312 | sequencer)) | |
313 | ||
314 | ;;;----- That's all, folks -------------------------------------------------- |