Add a new class slot `align', holding the instance layout alignment.
[sod] / src / builtin.lisp
CommitLineData
dea4d055
MW
1;;; -*-lisp-*-
2;;;
3;;; Builtin module provides the root of the class graph
4;;;
5;;; (c) 2009 Straylight/Edgeware
6;;;
7
8;;;----- Licensing notice ---------------------------------------------------
9;;;
e0808c47 10;;; This file is part of the Sensible Object Design, an object system for C.
dea4d055
MW
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;;; Infrastructure.
30
31(defvar *class-slot-alist* nil)
32
33(defun add-class-slot-function (name function)
ea578bb4 34 "Attach a slot function to the `*class-slot-alist*'.
dea4d055
MW
35
36 The FUNCTION is invoked with one argument, which is a `sod-class' object
37 to which it should add a slot. If a function with the same NAME is
38 already defined then that function is replaced; otherwise a new name/
39 function pair is defined.
40
41 Functions are are invoked in the order in which their names were first
42 added."
43
44 (aif (assoc name *class-slot-alist* :test #'string=)
45 (setf (cdr it) function)
46 (asetf *class-slot-alist* (append it (list (cons name function))))))
47
48(defmacro define-class-slot
49 (name (class &optional stream) type init &body prepare)
50 "Define a new class slot.
51
ea578bb4
MW
52 The slot will be called NAME (a string) and will be of TYPE (which should
53 be a type S-expression). The slot's (static) initializer will be
54 constructed by printing the value of INIT, which is evaluated with CLASS
55 bound to the class object being constructed. If any PREPARE forms are
56 provided, then they are evaluated as a progn, with CLASS bound to the
dea4d055
MW
57 class object, and STREAM bound to the output stream it should write on."
58
59 (with-gensyms (classvar)
60 `(add-class-slot-function
61 ',name
62 (lambda (,classvar)
63 (make-sod-slot ,classvar ,name (c-type ,type)
52a79ab8 64 (make-property-set :slot-class 'sod-class-slot
dea4d055
MW
65 :initializer-function
66 (lambda (,class)
67 ,init)
68 ,@(and prepare
69 `(:prepare-function
70 (lambda (,class ,stream)
71 ,@prepare)))))))))
72
73;;;--------------------------------------------------------------------------
74;;; Basic information.
75
76(define-class-slot "name" (class) const-string
77 (prin1-to-string (sod-class-name class)))
78
79(define-class-slot "nick" (class) const-string
80 (prin1-to-string (sod-class-nickname class)))
81
82;;;--------------------------------------------------------------------------
83;;; Instance allocation and initialization.
84
85(define-class-slot "initsz" (class) size-t
86 (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
87
8c2c58ae
MW
88(define-class-slot "align" (class) size-t
89 (format nil "SOD__ALIGNOF(struct ~A)" (ilayout-struct-tag class)))
90
dea4d055
MW
91(define-class-slot "imprint" (class stream)
92 (* (fun (* void) ("/*p*/" (* void))))
93 (format nil "~A__imprint" class)
94 (let ((ilayout (sod-class-ilayout class)))
95 (format stream "~&~:
96/* Imprint raw memory with instance structure. */
97static void *~A__imprint(void *p)
98{
99 struct ~A *sod__obj = p;
100
c2438e62 101 ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~}
dea4d055
MW
102 return (p);
103}~2%"
104 class
105 (ilayout-struct-tag class)
106 (mapcar (lambda (ichain)
107 (let* ((head (ichain-head ichain))
108 (tail (ichain-tail ichain)))
109 (list (sod-class-nickname head)
110 (sod-class-nickname tail)
c2438e62
MW
111 (vtable-name class head)
112 (sod-class-nickname tail))))
dea4d055
MW
113 (ilayout-ichains ilayout)))))
114
115(define-class-slot "init" (class stream)
116 (* (fun (* void) ("/*p*/" (* void))))
117 (format nil "~A__init" class)
118
119 ;; FIXME this needs a metaobject protocol
ea578bb4
MW
120 (let ((ilayout (sod-class-ilayout class))
121 (used nil))
dea4d055 122 (format stream "~&~:
ea578bb4
MW
123/* Provide initial values for an instance's slots. */
124static void *~A__init(void *p)~%{~%" class)
dea4d055 125 (dolist (ichain (ilayout-ichains ilayout))
ea578bb4 126 (let ((ich (format nil "sod__obj->~A.~A"
dea4d055
MW
127 (sod-class-nickname (ichain-head ichain))
128 (sod-class-nickname (ichain-tail ichain)))))
129 (dolist (item (ichain-body ichain))
130 (etypecase item
131 (vtable-pointer
132 nil)
133 (islots
134 (let ((isl (format nil "~A.~A"
135 ich
136 (sod-class-nickname (islots-class item)))))
137 (dolist (slot (islots-slots item))
138 (let ((dslot (effective-slot-direct-slot slot))
139 (init (effective-slot-initializer slot)))
140 (when init
ea578bb4
MW
141 (unless used
142 (format stream
9ec578d9
MW
143 " struct ~A *sod__obj = ~A__imprint(p);~2%"
144 (ilayout-struct-tag class) class)
ea578bb4 145 (setf used t))
f6eafb24
MW
146 (format stream " {~% ")
147 (pprint-c-type (sod-slot-type dslot) stream
148 *sod-tmp-val*)
149 (format stream " =")
dea4d055
MW
150 (ecase (sod-initializer-value-kind init)
151 (:simple (write (sod-initializer-value-form init)
152 :stream stream
153 :pretty nil :escape nil)
154 (format stream ";~%"))
1d8206e9 155 (:compound (format stream " {")
dea4d055
MW
156 (write (sod-initializer-value-form init)
157 :stream stream
158 :pretty nil :escape nil)
1d8206e9
MW
159 (format stream " };~%")))
160 (format stream " ~A.~A = ~A;~% }~%"
161 isl (sod-slot-name dslot)
162 *sod-tmp-val*))))))))))
ea578bb4
MW
163 (unless used
164 (format stream " ~A__imprint(p);~%" class))
dea4d055
MW
165 (format stream "~&~:
166 return (p);
167}~2%")))
168
169;;;--------------------------------------------------------------------------
170;;; Superclass structure.
171
172(define-class-slot "n_supers" (class) size-t
173 (length (sod-class-direct-superclasses class)))
174
175(define-class-slot "supers" (class stream)
176 (* (* (class "SodClass" :const) :const))
177 (if (null (sod-class-direct-superclasses class)) 0
178 (format nil "~A__supers" class))
179 (let ((supers (sod-class-direct-superclasses class)))
180 (when supers
181 (format stream "~&~:
182/* Direct superclasses. */
183static const SodClass *const ~A__supers[] = {
184 ~{~A__class~^,~% ~}
185};~2%"
186 class supers))))
187
188(define-class-slot "n_cpl" (class) size-t
189 (length (sod-class-precedence-list class)))
190
191(define-class-slot "cpl" (class stream)
192 (* (* (class "SodClass" :const) :const))
193 (format nil "~A__cpl" class)
194 (format stream "~&~:
195/* Class precedence list. */
196static const SodClass *const ~A__cpl[] = {
197 ~{~A__class~^,~% ~}
198};~2%"
199 class (sod-class-precedence-list class)))
200
201;;;--------------------------------------------------------------------------
202;;; Chain structure.
203
204(define-class-slot "link" (class) (* (class "SodClass" :const))
205 (aif (sod-class-chain-link class)
206 (format nil "~A__class" it)
207 0))
208
209(define-class-slot "head" (class) (* (class "SodClass" :const))
210 (format nil "~A__class" (sod-class-chain-head class)))
211
212(define-class-slot "level" (class) size-t
213 (position class (reverse (sod-class-chain class))))
214
215(define-class-slot "n_chains" (class) size-t
216 (length (sod-class-chains class)))
217
218(define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
219 (format nil "~A__chains" class)
220 (let ((chains (sod-class-chains class)))
221 (format stream "~&~:
222/* Chain structure. */
223~1@*~:{static const SodClass *const ~A__chain_~A[] = {
224 ~{~A__class~^,~% ~}
225};~:^~2%~}
226
227~0@*static const struct sod_chain ~A__chains[] = {
9ec578d9
MW
228~:{ { ~
229 /* n_classes = */ ~3@*~A,
230 /* classes = */ ~0@*~A__chain_~A,
231 /* off_ichain = */ ~4@*offsetof(struct ~A, ~A),
232 /* vt = */ (const struct sod_vtable *)&~A,
233 /* ichainsz = */ sizeof(struct ~A) }~:^,~%~}
dea4d055
MW
234};~2%"
235 class ;0
236 (mapcar (lambda (chain) ;1
237 (let* ((head (sod-class-chain-head (car chain)))
238 (chain-nick (sod-class-nickname head)))
9ec578d9
MW
239 (list class chain-nick ;0 1
240 (reverse chain) ;2
241 (length chain) ;3
242 (ilayout-struct-tag class) chain-nick ;4 5
243 (vtable-name class head) ;6
244 (ichain-struct-tag (car chain) head)))) ;7
dea4d055
MW
245 chains))))
246
247;;;--------------------------------------------------------------------------
248;;; Class-specific layout.
249
250(define-class-slot "off_islots" (class) size-t
9ec578d9
MW
251 (if (sod-class-slots class)
252 (format nil "offsetof(struct ~A, ~A)"
253 (ichain-struct-tag class (sod-class-chain-head class))
254 (sod-class-nickname class))
255 "0"))
dea4d055
MW
256
257(define-class-slot "islotsz" (class) size-t
9ec578d9
MW
258 (if (sod-class-slots class)
259 (format nil "sizeof(struct ~A)"
260 (islots-struct-tag class))
261 "0"))
dea4d055
MW
262
263;;;--------------------------------------------------------------------------
264;;; Bootstrapping the class graph.
265
266(defun bootstrap-classes (module)
ea578bb4
MW
267 "Bootstrap the braid in MODULE.
268
269 This builds the fundamental recursive braid, where `SodObject' is an
270 instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
271 an instance of itself)."
dea4d055
MW
272 (let* ((sod-object (make-sod-class "SodObject" nil
273 (make-property-set :nick 'obj)))
274 (sod-class (make-sod-class "SodClass" (list sod-object)
275 (make-property-set :nick 'cls)))
276 (classes (list sod-object sod-class)))
277
278 ;; Sort out the recursion.
279 (setf (slot-value sod-class 'chain-link) sod-object)
280 (dolist (class classes)
281 (setf (slot-value class 'metaclass) sod-class))
282
283 ;; Predeclare the class types.
284 (dolist (class classes)
285 (make-class-type (sod-class-name class)))
286
287 ;; Attach the class slots.
288 (dolist (slot *class-slot-alist*)
289 (funcall (cdr slot) sod-class))
290
291 ;; These classes are too closely intertwined. We must partially finalize
292 ;; them together by hand. This is cloned from `finalize-sod-class'.
293 (dolist (class classes)
294 (with-slots (class-precedence-list chain-head chain chains) class
295 (setf class-precedence-list (compute-cpl class))
296 (setf (values chain-head chain chains) (compute-chains class))))
297
298 ;; Done.
299 (dolist (class classes)
300 (finalize-sod-class class)
301 (add-to-module module class))))
302
73c17a81 303(export '*builtin-module*)
ea578bb4
MW
304(defvar *builtin-module* nil
305 "The builtin module.")
306
73c17a81 307(export 'make-builtin-module)
dea4d055 308(defun make-builtin-module ()
ea578bb4
MW
309 "Construct the builtin module.
310
9ec578d9
MW
311 This involves constructing the braid (which is done in
312 `bootstrap-classes') and defining a few obvious type names which users
313 will find handy.
ea578bb4
MW
314
315 Returns the newly constructed module, and stores it in the variable
316 `*builtin-module*'."
dea4d055
MW
317 (let ((module (make-instance 'module
318 :name (make-pathname :name "SOD-BASE"
319 :type "SOD"
320 :case :common)
ea578bb4 321 :state nil)))
9ec578d9 322 (with-module-environment (module)
0e7cdea0 323 (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
9ec578d9
MW
324 (add-to-module module (make-instance 'type-item :name name)))
325 (flet ((header-name (name)
326 (concatenate 'string "\"" (string-downcase name) ".h\""))
327 (add-includes (reason &rest names)
328 (let ((text (with-output-to-string (out)
329 (dolist (name names)
330 (format out "#include ~A~%" name)))))
331 (add-to-module module
332 (make-instance 'code-fragment-item
333 :reason reason
334 :constraints nil
335 :name :includes
336 :fragment text)))))
337 (add-includes :c (header-name "sod"))
338 (add-includes :h "<stddef.h>"))
339 (bootstrap-classes module))
ea578bb4 340 (setf *builtin-module* module)))
dea4d055 341
54c01772
MW
342(define-clear-the-decks builtin-module
343 (unless *builtin-module* (make-builtin-module)))
344
dea4d055 345;;;----- That's all, folks --------------------------------------------------