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