d7d0fcb18e99a5164e13b18ae55240c1922ef059
[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 ;;;--------------------------------------------------------------------------
113 ;;; Superclass structure.
114
115 (define-class-slot "n_supers" (class) size-t
116 (length (sod-class-direct-superclasses class)))
117
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)))
123 (when supers
124 (format stream "~&~:
125 /* Direct superclasses. */
126 static const SodClass *const ~A__supers[] = {
127 ~{~A__class~^,~% ~}
128 };~2%"
129 class supers))))
130
131 (define-class-slot "n_cpl" (class) size-t
132 (length (sod-class-precedence-list class)))
133
134 (define-class-slot "cpl" (class stream)
135 (* (* (class "SodClass" :const) :const))
136 (format nil "~A__cpl" class)
137 (format stream "~&~:
138 /* Class precedence list. */
139 static const SodClass *const ~A__cpl[] = {
140 ~{~A__class~^,~% ~}
141 };~2%"
142 class (sod-class-precedence-list class)))
143
144 ;;;--------------------------------------------------------------------------
145 ;;; Chain structure.
146
147 (define-class-slot "link" (class) (* (class "SodClass" :const))
148 (aif (sod-class-chain-link class)
149 (format nil "~A__class" it)
150 0))
151
152 (define-class-slot "head" (class) (* (class "SodClass" :const))
153 (format nil "~A__class" (sod-class-chain-head class)))
154
155 (define-class-slot "level" (class) size-t
156 (position class (reverse (sod-class-chain class))))
157
158 (define-class-slot "n_chains" (class) size-t
159 (length (sod-class-chains class)))
160
161 (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
162 (format nil "~A__chains" class)
163 (let ((chains (sod-class-chains class)))
164 (format stream "~&~:
165 /* Chain structure. */
166 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
167 ~{~A__class~^,~% ~}
168 };~:^~2%~}
169
170 ~0@*static const struct sod_chain ~A__chains[] = {
171 ~:{ { ~
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) }~:^,~%~}
177 };~2%"
178 class ;0
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
183 (reverse chain) ;2
184 (length chain) ;3
185 (ilayout-struct-tag class) chain-nick ;4 5
186 (vtable-name class head) ;6
187 (ichain-struct-tag (car chain) head)))) ;7
188 chains))))
189
190 ;;;--------------------------------------------------------------------------
191 ;;; Class-specific layout.
192
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))
198 "0"))
199
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))
204 "0"))
205
206 ;;;--------------------------------------------------------------------------
207 ;;; Built-in methods.
208
209 ;; Common protocol.
210
211 (defclass lifecycle-message (standard-message)
212 ())
213
214 (defclass lifecycle-effective-method (standard-effective-method)
215 ())
216
217 (defmethod effective-method-live-p ((method lifecycle-effective-method))
218 t)
219
220 (defgeneric lifecycle-method-kernel (method codegen target)
221 (:documentation
222 "Compute (into CODEGEN) the class-specific part of the METHOD.
223
224 The result, if any, needs to find its way to the TARGET, as usual."))
225
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)
231 (lambda (target)
232 (lifecycle-method-kernel method
233 codegen
234 target))))
235
236 ;; Utilities.
237
238 (defun declare-me (codegen class)
239 "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS.
240
241 The pointer refers to a part of the prevailing `sod__obj' object, which is
242 assumed to be a pointer to an appropriate `ilayout' structure."
243 (emit-decl codegen (make-var-inst "me" (c-type (* (class class)))
244 (format nil "&sod__obj->~A.~A"
245 (sod-class-nickname
246 (sod-class-chain-head class))
247 (sod-class-nickname class)))))
248
249 ;; Initialization.
250
251 (defclass initialization-message (lifecycle-message)
252 ())
253
254 (defclass initialization-effective-method (lifecycle-effective-method)
255 ())
256
257 (defmethod sod-message-effective-method-class
258 ((message initialization-message))
259 'initialization-effective-method)
260
261 (defmethod lifecycle-method-kernel
262 ((method initialization-effective-method) codegen target)
263 (let* ((class (effective-method-class method))
264 (ilayout (sod-class-ilayout class))
265 (obj-tag (ilayout-struct-tag class))
266 (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
267 (func-name (format nil "~A__init" class)))
268
269 ;; Start building the initialization function.
270 (codegen-push codegen)
271
272 (labels ((set-from-initializer (var type init)
273 ;; Store the value of INIT, which has the given TYPE, in VAR.
274 ;; INIT has the syntax of an initializer: declare and
275 ;; initialize a temporary, and then copy the result.
276 ;; Compilers seem to optimize this properly. Return the
277 ;; resulting code as an instruction.
278 (codegen-push codegen)
279 (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
280 (deliver-expr codegen var *sod-tmp-val*)
281 (codegen-pop-block codegen)))
282
283 ;; Initialize the structure defined by the various superclasses, in
284 ;; reverse precedence order.
285 (dolist (super (reverse (sod-class-precedence-list class)))
286 (let* ((ichain (find (sod-class-chain-head super)
287 (ilayout-ichains ilayout)
288 :key #'ichain-head))
289 (islots (find super (ichain-body ichain)
290 :test (lambda (class item)
291 (and (typep item 'islots)
292 (eq (islots-class item) class)))))
293 (frags (sod-class-initfrags super))
294 (this-class-focussed-p nil)
295 (isl (format nil "me->~A" (sod-class-nickname super))))
296
297 (flet ((focus-this-class ()
298 ;; Delayed initial preparation. Don't bother defining the
299 ;; `me' pointer if there's actually nothing to do.
300 (unless this-class-focussed-p
301 (emit-banner codegen
302 "Initialization for class `~A'." super)
303 (codegen-push codegen)
304 (declare-me codegen super)
305 (setf this-class-focussed-p t))))
306
307 ;; Work through each slot in turn.
308 (dolist (slot (and islots (islots-slots islots)))
309 (let ((dslot (effective-slot-direct-slot slot))
310 (init (effective-slot-initializer slot)))
311 (when init
312 (focus-this-class)
313 (let* ((slot-type (sod-slot-type dslot))
314 (slot-default (sod-initializer-value init))
315 (target (format nil "~A.~A"
316 isl (sod-slot-name dslot)))
317 (initinst (set-from-initializer target
318 slot-type
319 slot-default)))
320 (emit-inst codegen initinst)))))
321
322 ;; Emit the class's initialization fragments.
323 (when frags
324 (let ((used-me-p this-class-focussed-p))
325 (focus-this-class)
326 (unless used-me-p
327 (deliver-call codegen :void "SOD__IGNORE" "me")))
328 (dolist (frag frags)
329 (codegen-push codegen)
330 (emit-inst codegen frag)
331 (emit-inst codegen (codegen-pop-block codegen))))
332
333 ;; If we opened a block to initialize this class then close it
334 ;; again.
335 (when this-class-focussed-p
336 (emit-inst codegen (codegen-pop-block codegen)))))))
337
338 ;; Done making the initialization function.
339 (codegen-pop-function codegen func-name func-type
340 "Instance initialization function ~:_~
341 for class `~A'."
342 class)
343
344 (deliver-call codegen :void func-name "sod__obj")))
345
346 ;; Teardown.
347
348 (defclass teardown-message (lifecycle-message)
349 ())
350
351 (defclass teardown-effective-method (lifecycle-effective-method)
352 ())
353
354 (defmethod sod-message-effective-method-class ((message teardown-message))
355 'teardown-effective-method)
356
357 (defmethod lifecycle-method-kernel
358 ((method teardown-effective-method) codegen target)
359 (let* ((class (effective-method-class method))
360 (obj-tag (ilayout-struct-tag class))
361 (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
362 (func-name (format nil "~A__teardown" class)))
363 (codegen-push codegen)
364 (dolist (super (sod-class-precedence-list class))
365 (let ((frags (sod-class-tearfrags super)))
366 (when frags
367 (emit-banner codegen "Teardown for class `~A'." super)
368 (codegen-push codegen)
369 (declare-me codegen super)
370 (deliver-call codegen :void "SOD__IGNORE" "me")
371 (dolist (frag frags)
372 (codegen-push codegen)
373 (emit-inst codegen frag)
374 (emit-inst codegen (codegen-pop-block codegen)))
375 (emit-inst codegen (codegen-pop-block codegen)))))
376 (codegen-pop-function codegen func-name func-type
377 "Instance teardown function ~:_~
378 for class `~A'."
379 class)
380 (deliver-call codegen :void
381 (format nil "~A__teardown" class) "sod__obj")
382 (deliver-expr codegen target 0)))
383
384 ;;;--------------------------------------------------------------------------
385 ;;; Bootstrapping the class graph.
386
387 (defun bootstrap-classes (module)
388 "Bootstrap the braid in MODULE.
389
390 This builds the fundamental recursive braid, where `SodObject' is an
391 instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
392 an instance of itself)."
393 (let* ((sod-object (make-sod-class "SodObject" nil
394 (make-property-set :nick 'obj)))
395 (sod-class (make-sod-class "SodClass" (list sod-object)
396 (make-property-set :nick 'cls)))
397 (classes (list sod-object sod-class)))
398
399 ;; Attach the built-in messages.
400 (make-sod-message sod-object "init"
401 (c-type (fun void :keys))
402 (make-property-set
403 :message-class 'initialization-message))
404 (make-sod-message sod-object "teardown" (c-type (fun int))
405 (make-property-set :message-class 'teardown-message))
406
407 ;; Sort out the recursion.
408 (setf (slot-value sod-class 'chain-link) sod-object)
409 (dolist (class classes)
410 (setf (slot-value class 'metaclass) sod-class))
411
412 ;; Predeclare the class types.
413 (dolist (class classes)
414 (make-class-type (sod-class-name class)))
415
416 ;; Attach the class slots.
417 (dolist (slot *class-slot-alist*)
418 (funcall (cdr slot) sod-class))
419
420 ;; These classes are too closely intertwined. We must partially finalize
421 ;; them together by hand. This is cloned from `finalize-sod-class'.
422 (dolist (class classes)
423 (with-slots (class-precedence-list chain-head chain chains) class
424 (setf class-precedence-list (compute-cpl class))
425 (setf (values chain-head chain chains) (compute-chains class))))
426
427 ;; Done.
428 (dolist (class classes)
429 (finalize-sod-class class)
430 (add-to-module module class))))
431
432 (export '*builtin-module*)
433 (defvar *builtin-module* nil
434 "The builtin module.")
435
436 (export 'make-builtin-module)
437 (defun make-builtin-module ()
438 "Construct the builtin module.
439
440 This involves constructing the braid (which is done in
441 `bootstrap-classes') and defining a few obvious type names which users
442 will find handy.
443
444 Returns the newly constructed module, and stores it in the variable
445 `*builtin-module*'."
446 (let ((module (make-instance 'module
447 :name (make-pathname :name "SOD-BASE"
448 :type "SOD"
449 :case :common)
450 :state nil)))
451 (with-module-environment (module)
452 (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
453 (add-to-module module (make-instance 'type-item :name name)))
454 (flet ((header-name (name)
455 (concatenate 'string "\"" (string-downcase name) ".h\""))
456 (add-includes (reason &rest names)
457 (let ((text (with-output-to-string (out)
458 (dolist (name names)
459 (format out "#include ~A~%" name)))))
460 (add-to-module module
461 (make-instance 'code-fragment-item
462 :reason reason
463 :constraints nil
464 :name :includes
465 :fragment text)))))
466 (add-includes :c (header-name "sod"))
467 (add-includes :h "<stddef.h>"))
468 (bootstrap-classes module))
469 (setf *builtin-module* module)))
470
471 (define-clear-the-decks builtin-module
472 (unless *builtin-module* (make-builtin-module)))
473
474 ;;;----- That's all, folks --------------------------------------------------