src/: Abolish the distinction between different kinds of initializers.
[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
88(define-class-slot "imprint" (class stream)
89 (* (fun (* void) ("/*p*/" (* void))))
90 (format nil "~A__imprint" class)
91 (let ((ilayout (sod-class-ilayout class)))
92 (format stream "~&~:
7de8c666
MW
93/* Imprint raw memory with class `~A' instance structure. */
94static void *~:*~A__imprint(void *p)
dea4d055
MW
95{
96 struct ~A *sod__obj = p;
97
c2438e62 98 ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~}
dea4d055
MW
99 return (p);
100}~2%"
101 class
102 (ilayout-struct-tag class)
103 (mapcar (lambda (ichain)
104 (let* ((head (ichain-head ichain))
105 (tail (ichain-tail ichain)))
106 (list (sod-class-nickname head)
107 (sod-class-nickname tail)
c2438e62
MW
108 (vtable-name class head)
109 (sod-class-nickname tail))))
dea4d055
MW
110 (ilayout-ichains ilayout)))))
111
112(define-class-slot "init" (class stream)
113 (* (fun (* void) ("/*p*/" (* void))))
114 (format nil "~A__init" class)
115
116 ;; FIXME this needs a metaobject protocol
ea578bb4
MW
117 (let ((ilayout (sod-class-ilayout class))
118 (used nil))
dea4d055 119 (format stream "~&~:
ea578bb4
MW
120/* Provide initial values for an instance's slots. */
121static void *~A__init(void *p)~%{~%" class)
dea4d055 122 (dolist (ichain (ilayout-ichains ilayout))
ea578bb4 123 (let ((ich (format nil "sod__obj->~A.~A"
dea4d055
MW
124 (sod-class-nickname (ichain-head ichain))
125 (sod-class-nickname (ichain-tail ichain)))))
126 (dolist (item (ichain-body ichain))
127 (etypecase item
128 (vtable-pointer
129 nil)
130 (islots
131 (let ((isl (format nil "~A.~A"
132 ich
133 (sod-class-nickname (islots-class item)))))
134 (dolist (slot (islots-slots item))
135 (let ((dslot (effective-slot-direct-slot slot))
136 (init (effective-slot-initializer slot)))
137 (when init
ea578bb4
MW
138 (unless used
139 (format stream
9ec578d9
MW
140 " struct ~A *sod__obj = ~A__imprint(p);~2%"
141 (ilayout-struct-tag class) class)
ea578bb4 142 (setf used t))
f6eafb24
MW
143 (format stream " {~% ")
144 (pprint-c-type (sod-slot-type dslot) stream
145 *sod-tmp-val*)
a888e3ac
MW
146 (format stream " = ~A;~% ~
147 ~A.~A = ~A;~% ~
148 }~%"
149 (sod-initializer-value init)
1d8206e9
MW
150 isl (sod-slot-name dslot)
151 *sod-tmp-val*))))))))))
ea578bb4
MW
152 (unless used
153 (format stream " ~A__imprint(p);~%" class))
dea4d055
MW
154 (format stream "~&~:
155 return (p);
156}~2%")))
157
158;;;--------------------------------------------------------------------------
159;;; Superclass structure.
160
161(define-class-slot "n_supers" (class) size-t
162 (length (sod-class-direct-superclasses class)))
163
164(define-class-slot "supers" (class stream)
165 (* (* (class "SodClass" :const) :const))
166 (if (null (sod-class-direct-superclasses class)) 0
167 (format nil "~A__supers" class))
168 (let ((supers (sod-class-direct-superclasses class)))
169 (when supers
170 (format stream "~&~:
171/* Direct superclasses. */
172static const SodClass *const ~A__supers[] = {
173 ~{~A__class~^,~% ~}
174};~2%"
175 class supers))))
176
177(define-class-slot "n_cpl" (class) size-t
178 (length (sod-class-precedence-list class)))
179
180(define-class-slot "cpl" (class stream)
181 (* (* (class "SodClass" :const) :const))
182 (format nil "~A__cpl" class)
183 (format stream "~&~:
184/* Class precedence list. */
185static const SodClass *const ~A__cpl[] = {
186 ~{~A__class~^,~% ~}
187};~2%"
188 class (sod-class-precedence-list class)))
189
190;;;--------------------------------------------------------------------------
191;;; Chain structure.
192
193(define-class-slot "link" (class) (* (class "SodClass" :const))
194 (aif (sod-class-chain-link class)
195 (format nil "~A__class" it)
196 0))
197
198(define-class-slot "head" (class) (* (class "SodClass" :const))
199 (format nil "~A__class" (sod-class-chain-head class)))
200
201(define-class-slot "level" (class) size-t
202 (position class (reverse (sod-class-chain class))))
203
204(define-class-slot "n_chains" (class) size-t
205 (length (sod-class-chains class)))
206
207(define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
208 (format nil "~A__chains" class)
209 (let ((chains (sod-class-chains class)))
210 (format stream "~&~:
211/* Chain structure. */
212~1@*~:{static const SodClass *const ~A__chain_~A[] = {
213 ~{~A__class~^,~% ~}
214};~:^~2%~}
215
216~0@*static const struct sod_chain ~A__chains[] = {
9ec578d9
MW
217~:{ { ~
218 /* n_classes = */ ~3@*~A,
219 /* classes = */ ~0@*~A__chain_~A,
220 /* off_ichain = */ ~4@*offsetof(struct ~A, ~A),
221 /* vt = */ (const struct sod_vtable *)&~A,
222 /* ichainsz = */ sizeof(struct ~A) }~:^,~%~}
dea4d055
MW
223};~2%"
224 class ;0
225 (mapcar (lambda (chain) ;1
226 (let* ((head (sod-class-chain-head (car chain)))
227 (chain-nick (sod-class-nickname head)))
9ec578d9
MW
228 (list class chain-nick ;0 1
229 (reverse chain) ;2
230 (length chain) ;3
231 (ilayout-struct-tag class) chain-nick ;4 5
232 (vtable-name class head) ;6
233 (ichain-struct-tag (car chain) head)))) ;7
dea4d055
MW
234 chains))))
235
236;;;--------------------------------------------------------------------------
237;;; Class-specific layout.
238
239(define-class-slot "off_islots" (class) size-t
9ec578d9
MW
240 (if (sod-class-slots class)
241 (format nil "offsetof(struct ~A, ~A)"
242 (ichain-struct-tag class (sod-class-chain-head class))
243 (sod-class-nickname class))
244 "0"))
dea4d055
MW
245
246(define-class-slot "islotsz" (class) size-t
9ec578d9
MW
247 (if (sod-class-slots class)
248 (format nil "sizeof(struct ~A)"
249 (islots-struct-tag class))
250 "0"))
dea4d055
MW
251
252;;;--------------------------------------------------------------------------
253;;; Bootstrapping the class graph.
254
255(defun bootstrap-classes (module)
ea578bb4
MW
256 "Bootstrap the braid in MODULE.
257
258 This builds the fundamental recursive braid, where `SodObject' is an
259 instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
260 an instance of itself)."
dea4d055
MW
261 (let* ((sod-object (make-sod-class "SodObject" nil
262 (make-property-set :nick 'obj)))
263 (sod-class (make-sod-class "SodClass" (list sod-object)
264 (make-property-set :nick 'cls)))
265 (classes (list sod-object sod-class)))
266
267 ;; Sort out the recursion.
268 (setf (slot-value sod-class 'chain-link) sod-object)
269 (dolist (class classes)
270 (setf (slot-value class 'metaclass) sod-class))
271
272 ;; Predeclare the class types.
273 (dolist (class classes)
274 (make-class-type (sod-class-name class)))
275
276 ;; Attach the class slots.
277 (dolist (slot *class-slot-alist*)
278 (funcall (cdr slot) sod-class))
279
280 ;; These classes are too closely intertwined. We must partially finalize
281 ;; them together by hand. This is cloned from `finalize-sod-class'.
282 (dolist (class classes)
283 (with-slots (class-precedence-list chain-head chain chains) class
284 (setf class-precedence-list (compute-cpl class))
285 (setf (values chain-head chain chains) (compute-chains class))))
286
287 ;; Done.
288 (dolist (class classes)
289 (finalize-sod-class class)
290 (add-to-module module class))))
291
73c17a81 292(export '*builtin-module*)
ea578bb4
MW
293(defvar *builtin-module* nil
294 "The builtin module.")
295
73c17a81 296(export 'make-builtin-module)
dea4d055 297(defun make-builtin-module ()
ea578bb4
MW
298 "Construct the builtin module.
299
9ec578d9
MW
300 This involves constructing the braid (which is done in
301 `bootstrap-classes') and defining a few obvious type names which users
302 will find handy.
ea578bb4
MW
303
304 Returns the newly constructed module, and stores it in the variable
305 `*builtin-module*'."
dea4d055
MW
306 (let ((module (make-instance 'module
307 :name (make-pathname :name "SOD-BASE"
308 :type "SOD"
309 :case :common)
ea578bb4 310 :state nil)))
9ec578d9 311 (with-module-environment (module)
0e7cdea0 312 (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
9ec578d9
MW
313 (add-to-module module (make-instance 'type-item :name name)))
314 (flet ((header-name (name)
315 (concatenate 'string "\"" (string-downcase name) ".h\""))
316 (add-includes (reason &rest names)
317 (let ((text (with-output-to-string (out)
318 (dolist (name names)
319 (format out "#include ~A~%" name)))))
320 (add-to-module module
321 (make-instance 'code-fragment-item
322 :reason reason
323 :constraints nil
324 :name :includes
325 :fragment text)))))
326 (add-includes :c (header-name "sod"))
327 (add-includes :h "<stddef.h>"))
328 (bootstrap-classes module))
ea578bb4 329 (setf *builtin-module* module)))
dea4d055 330
54c01772
MW
331(define-clear-the-decks builtin-module
332 (unless *builtin-module* (make-builtin-module)))
333
dea4d055 334;;;----- That's all, folks --------------------------------------------------