3 ;;; Builtin module provides the root of the class graph
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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 (defvar *class-slot-alist* nil)
33 (defun add-class-slot-function (name function)
34 "Attach a slot function to the `*class-slot-alist*'.
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.
41 Functions are are invoked in the order in which their names were first
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))))))
48 (defmacro define-class-slot
49 (name (class &optional stream) type init &body prepare)
50 "Define a new class slot.
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."
59 (with-gensyms (classvar)
60 `(add-class-slot-function
63 (make-sod-slot ,classvar ,name (c-type ,type)
64 (make-property-set :slot-class 'sod-class-slot
70 (lambda (,class ,stream)
73 ;;;--------------------------------------------------------------------------
74 ;;; Basic information.
76 (define-class-slot "name" (class) const-string
77 (prin1-to-string (sod-class-name class)))
79 (define-class-slot "nick" (class) const-string
80 (prin1-to-string (sod-class-nickname class)))
82 ;;;--------------------------------------------------------------------------
83 ;;; Instance allocation and initialization.
85 (define-class-slot "initsz" (class) size-t
86 (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
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)))
93 /* Imprint raw memory with class `~A' instance structure. */
94 static void *~:*~A__imprint(void *p)
96 struct ~A *sod__obj = p;
98 ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~}
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)))))
112 ;;;--------------------------------------------------------------------------
113 ;;; Superclass structure.
115 (define-class-slot "n_supers" (class) size-t
116 (length (sod-class-direct-superclasses class)))
118 (define-class-slot "supers" (class stream)
119 (* (* (class "SodClass" :const) :const))
120 (if (null (sod-class-direct-superclasses class)) 0
121 (format nil "~A__supers" class))
122 (let ((supers (sod-class-direct-superclasses class)))
125 /* Direct superclasses. */
126 static const SodClass *const ~A__supers[] = {
131 (define-class-slot "n_cpl" (class) size-t
132 (length (sod-class-precedence-list class)))
134 (define-class-slot "cpl" (class stream)
135 (* (* (class "SodClass" :const) :const))
136 (format nil "~A__cpl" class)
138 /* Class precedence list. */
139 static const SodClass *const ~A__cpl[] = {
142 class (sod-class-precedence-list class)))
144 ;;;--------------------------------------------------------------------------
147 (define-class-slot "link" (class) (* (class "SodClass" :const))
148 (aif (sod-class-chain-link class)
149 (format nil "~A__class" it)
152 (define-class-slot "head" (class) (* (class "SodClass" :const))
153 (format nil "~A__class" (sod-class-chain-head class)))
155 (define-class-slot "level" (class) size-t
156 (position class (reverse (sod-class-chain class))))
158 (define-class-slot "n_chains" (class) size-t
159 (length (sod-class-chains class)))
161 (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
162 (format nil "~A__chains" class)
163 (let ((chains (sod-class-chains class)))
165 /* Chain structure. */
166 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
170 ~0@*static const struct sod_chain ~A__chains[] = {
172 /* n_classes = */ ~3@*~A,
173 /* classes = */ ~0@*~A__chain_~A,
174 /* off_ichain = */ ~4@*offsetof(struct ~A, ~A),
175 /* vt = */ (const struct sod_vtable *)&~A,
176 /* ichainsz = */ sizeof(struct ~A) }~:^,~%~}
179 (mapcar (lambda (chain) ;1
180 (let* ((head (sod-class-chain-head (car chain)))
181 (chain-nick (sod-class-nickname head)))
182 (list class chain-nick ;0 1
185 (ilayout-struct-tag class) chain-nick ;4 5
186 (vtable-name class head) ;6
187 (ichain-struct-tag (car chain) head)))) ;7
190 ;;;--------------------------------------------------------------------------
191 ;;; Class-specific layout.
193 (define-class-slot "off_islots" (class) size-t
194 (if (sod-class-slots class)
195 (format nil "offsetof(struct ~A, ~A)"
196 (ichain-struct-tag class (sod-class-chain-head class))
197 (sod-class-nickname class))
200 (define-class-slot "islotsz" (class) size-t
201 (if (sod-class-slots class)
202 (format nil "sizeof(struct ~A)"
203 (islots-struct-tag class))
206 ;;;--------------------------------------------------------------------------
207 ;;; Built-in methods.
211 (defclass lifecycle-message (standard-message)
214 (defclass lifecycle-effective-method (standard-effective-method)
217 (defmethod effective-method-live-p ((method lifecycle-effective-method))
220 (defgeneric lifecycle-method-kernel (method codegen target)
222 "Compute (into CODEGEN) the class-specific part of the METHOD.
224 The result, if any, needs to find its way to the TARGET, as usual."))
226 (defmethod simple-method-body
227 ((method lifecycle-effective-method) codegen target)
228 (invoke-delegation-chain codegen target
229 (effective-method-basic-argument-names method)
230 (effective-method-primary-methods method)
232 (lifecycle-method-kernel method
238 (defclass initialization-message (lifecycle-message)
241 (defclass initialization-effective-method (lifecycle-effective-method)
244 (defmethod sod-message-effective-method-class
245 ((message initialization-message))
246 'initialization-effective-method)
248 (defmethod lifecycle-method-kernel
249 ((method initialization-effective-method) codegen target)
250 (let* ((class (effective-method-class method))
251 (ilayout (sod-class-ilayout class))
252 (obj-tag (ilayout-struct-tag class))
253 (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
254 (func-name (format nil "~A__init" class)))
256 ;; Start building the initialization function.
257 (codegen-push codegen)
259 (labels ((set-from-initializer (var type init)
260 ;; Store the value of INIT, which has the given TYPE, in VAR.
261 ;; INIT has the syntax of an initializer: declare and
262 ;; initialize a temporary, and then copy the result.
263 ;; Compilers seem to optimize this properly. Return the
264 ;; resulting code as an instruction.
265 (codegen-push codegen)
266 (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
267 (deliver-expr codegen var *sod-tmp-val*)
268 (codegen-pop-block codegen)))
270 ;; Loop over the instance layout emitting initializers as we find them.
271 (dolist (ichain (ilayout-ichains ilayout))
272 (let ((ich (format nil "sod__obj->~A.~A"
273 (sod-class-nickname (ichain-head ichain))
274 (sod-class-nickname (ichain-tail ichain)))))
275 (dolist (item (ichain-body ichain))
280 (let ((isl (format nil "~A.~A"
282 (sod-class-nickname (islots-class item)))))
283 (dolist (slot (islots-slots item))
284 (let ((dslot (effective-slot-direct-slot slot))
285 (init (effective-slot-initializer slot)))
287 (let* ((slot-type (sod-slot-type dslot))
288 (slot-default (sod-initializer-value init))
289 (target (format nil "~A.~A"
290 isl (sod-slot-name dslot)))
291 (initinst (set-from-initializer target
294 (emit-inst codegen initinst))))))))))))
296 ;; Done making the initialization function.
297 (codegen-pop-function codegen func-name func-type
298 "Instance initialization function ~:_~
302 (deliver-call codegen :void func-name "sod__obj")))
304 ;;;--------------------------------------------------------------------------
305 ;;; Bootstrapping the class graph.
307 (defun bootstrap-classes (module)
308 "Bootstrap the braid in MODULE.
310 This builds the fundamental recursive braid, where `SodObject' is an
311 instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
312 an instance of itself)."
313 (let* ((sod-object (make-sod-class "SodObject" nil
314 (make-property-set :nick 'obj)))
315 (sod-class (make-sod-class "SodClass" (list sod-object)
316 (make-property-set :nick 'cls)))
317 (classes (list sod-object sod-class)))
319 ;; Attach the built-in messages.
320 (make-sod-message sod-object "init"
321 (c-type (fun void :keys))
323 :message-class 'initialization-message))
325 ;; Sort out the recursion.
326 (setf (slot-value sod-class 'chain-link) sod-object)
327 (dolist (class classes)
328 (setf (slot-value class 'metaclass) sod-class))
330 ;; Predeclare the class types.
331 (dolist (class classes)
332 (make-class-type (sod-class-name class)))
334 ;; Attach the class slots.
335 (dolist (slot *class-slot-alist*)
336 (funcall (cdr slot) sod-class))
338 ;; These classes are too closely intertwined. We must partially finalize
339 ;; them together by hand. This is cloned from `finalize-sod-class'.
340 (dolist (class classes)
341 (with-slots (class-precedence-list chain-head chain chains) class
342 (setf class-precedence-list (compute-cpl class))
343 (setf (values chain-head chain chains) (compute-chains class))))
346 (dolist (class classes)
347 (finalize-sod-class class)
348 (add-to-module module class))))
350 (export '*builtin-module*)
351 (defvar *builtin-module* nil
352 "The builtin module.")
354 (export 'make-builtin-module)
355 (defun make-builtin-module ()
356 "Construct the builtin module.
358 This involves constructing the braid (which is done in
359 `bootstrap-classes') and defining a few obvious type names which users
362 Returns the newly constructed module, and stores it in the variable
364 (let ((module (make-instance 'module
365 :name (make-pathname :name "SOD-BASE"
369 (with-module-environment (module)
370 (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
371 (add-to-module module (make-instance 'type-item :name name)))
372 (flet ((header-name (name)
373 (concatenate 'string "\"" (string-downcase name) ".h\""))
374 (add-includes (reason &rest names)
375 (let ((text (with-output-to-string (out)
377 (format out "#include ~A~%" name)))))
378 (add-to-module module
379 (make-instance 'code-fragment-item
384 (add-includes :c (header-name "sod"))
385 (add-includes :h "<stddef.h>"))
386 (bootstrap-classes module))
387 (setf *builtin-module* module)))
389 (define-clear-the-decks builtin-module
390 (unless *builtin-module* (make-builtin-module)))
392 ;;;----- That's all, folks --------------------------------------------------