| 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 "align" (class) size-t |
| 89 | (format nil "SOD__ALIGNOF(struct ~A)" (ilayout-struct-tag class))) |
| 90 | |
| 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 class `~A' instance structure. */ |
| 97 | static void *~:*~A__imprint(void *p) |
| 98 | { |
| 99 | struct ~A *sod__obj = p; |
| 100 | |
| 101 | ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~} |
| 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) |
| 111 | (vtable-name class head) |
| 112 | (sod-class-nickname tail)))) |
| 113 | (ilayout-ichains ilayout))))) |
| 114 | |
| 115 | ;;;-------------------------------------------------------------------------- |
| 116 | ;;; Superclass structure. |
| 117 | |
| 118 | (define-class-slot "n_supers" (class) size-t |
| 119 | (length (sod-class-direct-superclasses class))) |
| 120 | |
| 121 | (define-class-slot "supers" (class stream) |
| 122 | (* (* (class "SodClass" :const) :const)) |
| 123 | (if (null (sod-class-direct-superclasses class)) 0 |
| 124 | (format nil "~A__supers" class)) |
| 125 | (let ((supers (sod-class-direct-superclasses class))) |
| 126 | (when supers |
| 127 | (format stream "~&~: |
| 128 | /* Direct superclasses. */ |
| 129 | static const SodClass *const ~A__supers[] = { |
| 130 | ~{~A__class~^,~% ~} |
| 131 | };~2%" |
| 132 | class supers)))) |
| 133 | |
| 134 | (define-class-slot "n_cpl" (class) size-t |
| 135 | (length (sod-class-precedence-list class))) |
| 136 | |
| 137 | (define-class-slot "cpl" (class stream) |
| 138 | (* (* (class "SodClass" :const) :const)) |
| 139 | (format nil "~A__cpl" class) |
| 140 | (format stream "~&~: |
| 141 | /* Class precedence list. */ |
| 142 | static const SodClass *const ~A__cpl[] = { |
| 143 | ~{~A__class~^,~% ~} |
| 144 | };~2%" |
| 145 | class (sod-class-precedence-list class))) |
| 146 | |
| 147 | ;;;-------------------------------------------------------------------------- |
| 148 | ;;; Chain structure. |
| 149 | |
| 150 | (define-class-slot "link" (class) (* (class "SodClass" :const)) |
| 151 | (aif (sod-class-chain-link class) |
| 152 | (format nil "~A__class" it) |
| 153 | 0)) |
| 154 | |
| 155 | (define-class-slot "head" (class) (* (class "SodClass" :const)) |
| 156 | (format nil "~A__class" (sod-class-chain-head class))) |
| 157 | |
| 158 | (define-class-slot "level" (class) size-t |
| 159 | (position class (reverse (sod-class-chain class)))) |
| 160 | |
| 161 | (define-class-slot "n_chains" (class) size-t |
| 162 | (length (sod-class-chains class))) |
| 163 | |
| 164 | (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const)) |
| 165 | (format nil "~A__chains" class) |
| 166 | (let ((chains (sod-class-chains class))) |
| 167 | (format stream "~&~: |
| 168 | /* Chain structure. */ |
| 169 | ~1@*~:{static const SodClass *const ~A__chain_~A[] = { |
| 170 | ~{~A__class~^,~% ~} |
| 171 | };~:^~2%~} |
| 172 | |
| 173 | ~0@*static const struct sod_chain ~A__chains[] = { |
| 174 | ~:{ { ~ |
| 175 | /* n_classes = */ ~3@*~A, |
| 176 | /* classes = */ ~0@*~A__chain_~A, |
| 177 | /* off_ichain = */ ~4@*offsetof(struct ~A, ~A), |
| 178 | /* vt = */ (const struct sod_vtable *)&~A, |
| 179 | /* ichainsz = */ sizeof(struct ~A) }~:^,~%~} |
| 180 | };~2%" |
| 181 | class ;0 |
| 182 | (mapcar (lambda (chain) ;1 |
| 183 | (let* ((head (sod-class-chain-head (car chain))) |
| 184 | (chain-nick (sod-class-nickname head))) |
| 185 | (list class chain-nick ;0 1 |
| 186 | (reverse chain) ;2 |
| 187 | (length chain) ;3 |
| 188 | (ilayout-struct-tag class) chain-nick ;4 5 |
| 189 | (vtable-name class head) ;6 |
| 190 | (ichain-struct-tag (car chain) head)))) ;7 |
| 191 | chains)))) |
| 192 | |
| 193 | ;;;-------------------------------------------------------------------------- |
| 194 | ;;; Class-specific layout. |
| 195 | |
| 196 | (define-class-slot "off_islots" (class) size-t |
| 197 | (if (sod-class-slots class) |
| 198 | (format nil "offsetof(struct ~A, ~A)" |
| 199 | (ichain-struct-tag class (sod-class-chain-head class)) |
| 200 | (sod-class-nickname class)) |
| 201 | "0")) |
| 202 | |
| 203 | (define-class-slot "islotsz" (class) size-t |
| 204 | (if (sod-class-slots class) |
| 205 | (format nil "sizeof(struct ~A)" |
| 206 | (islots-struct-tag class)) |
| 207 | "0")) |
| 208 | |
| 209 | ;;;-------------------------------------------------------------------------- |
| 210 | ;;; Built-in methods. |
| 211 | |
| 212 | ;; Common protocol. |
| 213 | |
| 214 | (defclass lifecycle-message (standard-message) |
| 215 | ()) |
| 216 | |
| 217 | (defclass lifecycle-effective-method (standard-effective-method) |
| 218 | ()) |
| 219 | |
| 220 | (defmethod effective-method-live-p ((method lifecycle-effective-method)) |
| 221 | t) |
| 222 | |
| 223 | (defgeneric lifecycle-method-kernel (method codegen target) |
| 224 | (:documentation |
| 225 | "Compute (into CODEGEN) the class-specific part of the METHOD. |
| 226 | |
| 227 | The result, if any, needs to find its way to the TARGET, as usual.")) |
| 228 | |
| 229 | (defmethod simple-method-body |
| 230 | ((method lifecycle-effective-method) codegen target) |
| 231 | (invoke-delegation-chain codegen target |
| 232 | (effective-method-basic-argument-names method) |
| 233 | (effective-method-primary-methods method) |
| 234 | (lambda (target) |
| 235 | (lifecycle-method-kernel method |
| 236 | codegen |
| 237 | target)))) |
| 238 | |
| 239 | ;; Utilities. |
| 240 | |
| 241 | (defun declare-me (codegen class) |
| 242 | "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS. |
| 243 | |
| 244 | The pointer refers to a part of the prevailing `sod__obj' object, which is |
| 245 | assumed to be a pointer to an appropriate `ilayout' structure." |
| 246 | (emit-decl codegen (make-var-inst "me" (c-type (* (class class))) |
| 247 | (format nil "&sod__obj->~A.~A" |
| 248 | (sod-class-nickname |
| 249 | (sod-class-chain-head class)) |
| 250 | (sod-class-nickname class))))) |
| 251 | |
| 252 | (defun collect-initarg-keywords (class) |
| 253 | "Return a list of keyword arguments corresponding to CLASS's initargs. |
| 254 | |
| 255 | For each distinct name among the initargs defined on CLASS and its |
| 256 | superclasses, return a single `argument' object containing the (agreed |
| 257 | common) type, and the (unique, if present) default value from the most |
| 258 | specific defining superclass. |
| 259 | |
| 260 | The arguments are not returned in any especially meaningful order." |
| 261 | |
| 262 | (let ((map (make-hash-table :test #'equal)) |
| 263 | (default-map (make-hash-table :test #'equal)) |
| 264 | (list nil)) |
| 265 | (dolist (super (sod-class-precedence-list class)) |
| 266 | (dolist (initarg (sod-class-initargs super)) |
| 267 | (let ((name (sod-initarg-name initarg)) |
| 268 | (default (sod-initarg-default initarg))) |
| 269 | (unless (gethash name default-map) |
| 270 | (when (or default (not (gethash name map))) |
| 271 | (setf (gethash name map) (sod-initarg-argument initarg))) |
| 272 | (when default |
| 273 | (setf (gethash name default-map) t)))))) |
| 274 | (maphash (lambda (key value) |
| 275 | (declare (ignore key)) |
| 276 | (push value list)) |
| 277 | map) |
| 278 | list)) |
| 279 | |
| 280 | (definst suppliedp-struct (stream) (flags var) |
| 281 | (format stream |
| 282 | "~@<struct { ~2I~_~{unsigned ~A : 1;~^ ~_~} ~I~_} ~A;~:>" |
| 283 | flags var)) |
| 284 | |
| 285 | ;; Initialization. |
| 286 | |
| 287 | (defclass initialization-message (lifecycle-message) |
| 288 | ()) |
| 289 | |
| 290 | (defclass initialization-effective-method (lifecycle-effective-method) |
| 291 | ()) |
| 292 | |
| 293 | (defmethod sod-message-effective-method-class |
| 294 | ((message initialization-message)) |
| 295 | 'initialization-effective-method) |
| 296 | |
| 297 | (defmethod method-keyword-argument-lists |
| 298 | ((method initialization-effective-method) direct-methods state) |
| 299 | (append (call-next-method) |
| 300 | (mapcan (lambda (class) |
| 301 | (let* ((initargs (sod-class-initargs class)) |
| 302 | (map (make-hash-table)) |
| 303 | (arglist (mapcar |
| 304 | (lambda (initarg) |
| 305 | (let ((arg (sod-initarg-argument |
| 306 | initarg))) |
| 307 | (setf (gethash arg map) initarg) |
| 308 | arg)) |
| 309 | initargs))) |
| 310 | (and initargs |
| 311 | (list (cons (lambda (arg) |
| 312 | (info-with-location |
| 313 | (gethash arg map) |
| 314 | "Type `~A' from initarg ~ |
| 315 | in class `~A' (here)" |
| 316 | (argument-type arg) class) |
| 317 | (report-inheritance-path |
| 318 | state class)) |
| 319 | arglist))))) |
| 320 | (sod-class-precedence-list |
| 321 | (effective-method-class method))))) |
| 322 | |
| 323 | (defmethod lifecycle-method-kernel |
| 324 | ((method initialization-effective-method) codegen target) |
| 325 | (let* ((class (effective-method-class method)) |
| 326 | (keywords (collect-initarg-keywords class)) |
| 327 | (ilayout (sod-class-ilayout class)) |
| 328 | (obj-tag (ilayout-struct-tag class)) |
| 329 | (kw-tag (effective-method-keyword-struct-tag method)) |
| 330 | (kw-tail (and keywords |
| 331 | (list (make-argument |
| 332 | "sod__kw" |
| 333 | (c-type (* (struct kw-tag :const))))))) |
| 334 | (func-type (c-type (fun void |
| 335 | ("sod__obj" (* (struct obj-tag))) |
| 336 | . kw-tail))) |
| 337 | (func-name (format nil "~A__init" class)) |
| 338 | (done-setup-p nil)) |
| 339 | |
| 340 | ;; Start building the initialization function. |
| 341 | (codegen-push codegen) |
| 342 | |
| 343 | (labels ((set-from-initializer (var type init) |
| 344 | ;; Store the value of INIT, which has the given TYPE, in VAR. |
| 345 | ;; INIT has the syntax of an initializer: declare and |
| 346 | ;; initialize a temporary, and then copy the result. |
| 347 | ;; Compilers seem to optimize this properly. Return the |
| 348 | ;; resulting code as an instruction. |
| 349 | (codegen-push codegen) |
| 350 | (emit-decl codegen (make-var-inst *sod-tmp-val* type init)) |
| 351 | (deliver-expr codegen var *sod-tmp-val*) |
| 352 | (codegen-pop-block codegen)) |
| 353 | (setup () |
| 354 | ;; Do any necessary one-time initialization required to set up |
| 355 | ;; the environment for the initialization code. |
| 356 | (unless done-setup-p |
| 357 | |
| 358 | ;; Extract the keyword arguments into local variables. |
| 359 | (when keywords |
| 360 | (emit-decl codegen |
| 361 | (make-suppliedp-struct-inst |
| 362 | (mapcar #'argument-name keywords) |
| 363 | "suppliedp")) |
| 364 | (emit-banner codegen "Collect the keyword arguments.") |
| 365 | (dolist (arg keywords) |
| 366 | (let* ((name (argument-name arg)) |
| 367 | (type (argument-type arg)) |
| 368 | (default (argument-default arg)) |
| 369 | (kwvar (format nil "sod__kw->~A" name)) |
| 370 | (kwset (make-set-inst name kwvar)) |
| 371 | (suppliedp (format nil "suppliedp.~A" name))) |
| 372 | (emit-decl codegen (make-var-inst name type)) |
| 373 | (deliver-expr codegen suppliedp |
| 374 | (format nil "sod__kw->~A__suppliedp" |
| 375 | name)) |
| 376 | (emit-inst |
| 377 | codegen |
| 378 | (if default |
| 379 | (make-if-inst suppliedp kwset |
| 380 | (set-from-initializer name |
| 381 | type |
| 382 | default)) |
| 383 | kwset)))) |
| 384 | |
| 385 | (deliver-call codegen :void |
| 386 | "SOD__IGNORE" "suppliedp") |
| 387 | (dolist (arg keywords) |
| 388 | (deliver-call codegen :void |
| 389 | "SOD__IGNORE" (argument-name arg)))) |
| 390 | |
| 391 | (setf done-setup-p t)))) |
| 392 | |
| 393 | ;; Initialize the structure defined by the various superclasses, in |
| 394 | ;; reverse precedence order. |
| 395 | (dolist (super (reverse (sod-class-precedence-list class))) |
| 396 | (let* ((ichain (find (sod-class-chain-head super) |
| 397 | (ilayout-ichains ilayout) |
| 398 | :key #'ichain-head)) |
| 399 | (islots (find super (ichain-body ichain) |
| 400 | :test (lambda (class item) |
| 401 | (and (typep item 'islots) |
| 402 | (eq (islots-class item) class))))) |
| 403 | (frags (sod-class-initfrags super)) |
| 404 | (this-class-focussed-p nil) |
| 405 | (isl (format nil "me->~A" (sod-class-nickname super)))) |
| 406 | |
| 407 | (flet ((focus-this-class () |
| 408 | ;; Delayed initial preparation. Don't bother defining the |
| 409 | ;; `me' pointer if there's actually nothing to do. |
| 410 | (setup) |
| 411 | (unless this-class-focussed-p |
| 412 | (emit-banner codegen |
| 413 | "Initialization for class `~A'." super) |
| 414 | (codegen-push codegen) |
| 415 | (declare-me codegen super) |
| 416 | (setf this-class-focussed-p t)))) |
| 417 | |
| 418 | ;; Work through each slot in turn. |
| 419 | (dolist (slot (and islots (islots-slots islots))) |
| 420 | (let ((dslot (effective-slot-direct-slot slot)) |
| 421 | (init (effective-slot-initializer slot)) |
| 422 | (initargs (effective-slot-initargs slot))) |
| 423 | (when (or init initargs) |
| 424 | (focus-this-class) |
| 425 | (let* ((slot-type (sod-slot-type dslot)) |
| 426 | (slot-default (sod-initializer-value init)) |
| 427 | (target (format nil "~A.~A" |
| 428 | isl (sod-slot-name dslot))) |
| 429 | (initinst (set-from-initializer target |
| 430 | slot-type |
| 431 | slot-default))) |
| 432 | |
| 433 | ;; If there are applicable initialization arguments, |
| 434 | ;; check to see whether they were supplied. |
| 435 | (dolist (initarg (reverse (remove-duplicates |
| 436 | initargs |
| 437 | :key #'sod-initarg-name |
| 438 | :test #'string=))) |
| 439 | (let ((arg-name (sod-initarg-name initarg))) |
| 440 | (setf initinst (make-if-inst |
| 441 | (format nil "suppliedp.~A" arg-name) |
| 442 | (make-set-inst target arg-name) |
| 443 | initinst)))) |
| 444 | |
| 445 | (emit-inst codegen initinst))))) |
| 446 | |
| 447 | ;; Emit the class's initialization fragments. |
| 448 | (when frags |
| 449 | (let ((used-me-p this-class-focussed-p)) |
| 450 | (focus-this-class) |
| 451 | (unless used-me-p |
| 452 | (deliver-call codegen :void "SOD__IGNORE" "me"))) |
| 453 | (dolist (frag frags) |
| 454 | (codegen-push codegen) |
| 455 | (emit-inst codegen frag) |
| 456 | (emit-inst codegen (codegen-pop-block codegen)))) |
| 457 | |
| 458 | ;; If we opened a block to initialize this class then close it |
| 459 | ;; again. |
| 460 | (when this-class-focussed-p |
| 461 | (emit-inst codegen (codegen-pop-block codegen))))))) |
| 462 | |
| 463 | ;; Done making the initialization function. |
| 464 | (codegen-pop-function codegen func-name func-type |
| 465 | "Instance initialization function ~:_~ |
| 466 | for class `~A'." |
| 467 | class) |
| 468 | |
| 469 | (apply #'deliver-call codegen :void func-name |
| 470 | "sod__obj" (and keywords (list (keyword-struct-pointer)))))) |
| 471 | |
| 472 | ;; Teardown. |
| 473 | |
| 474 | (defclass teardown-message (lifecycle-message) |
| 475 | ()) |
| 476 | |
| 477 | (defclass teardown-effective-method (lifecycle-effective-method) |
| 478 | ()) |
| 479 | |
| 480 | (defmethod sod-message-effective-method-class ((message teardown-message)) |
| 481 | 'teardown-effective-method) |
| 482 | |
| 483 | (defmethod lifecycle-method-kernel |
| 484 | ((method teardown-effective-method) codegen target) |
| 485 | (let* ((class (effective-method-class method)) |
| 486 | (obj-tag (ilayout-struct-tag class)) |
| 487 | (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag)))))) |
| 488 | (func-name (format nil "~A__teardown" class))) |
| 489 | (codegen-push codegen) |
| 490 | (dolist (super (sod-class-precedence-list class)) |
| 491 | (let ((frags (sod-class-tearfrags super))) |
| 492 | (when frags |
| 493 | (emit-banner codegen "Teardown for class `~A'." super) |
| 494 | (codegen-push codegen) |
| 495 | (declare-me codegen super) |
| 496 | (deliver-call codegen :void "SOD__IGNORE" "me") |
| 497 | (dolist (frag frags) |
| 498 | (codegen-push codegen) |
| 499 | (emit-inst codegen frag) |
| 500 | (emit-inst codegen (codegen-pop-block codegen))) |
| 501 | (emit-inst codegen (codegen-pop-block codegen))))) |
| 502 | (codegen-pop-function codegen func-name func-type |
| 503 | "Instance teardown function ~:_~ |
| 504 | for class `~A'." |
| 505 | class) |
| 506 | (deliver-call codegen :void |
| 507 | (format nil "~A__teardown" class) "sod__obj") |
| 508 | (deliver-expr codegen target 0))) |
| 509 | |
| 510 | ;;;-------------------------------------------------------------------------- |
| 511 | ;;; Bootstrapping the class graph. |
| 512 | |
| 513 | (defun bootstrap-classes (module) |
| 514 | "Bootstrap the braid in MODULE. |
| 515 | |
| 516 | This builds the fundamental recursive braid, where `SodObject' is an |
| 517 | instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and |
| 518 | an instance of itself)." |
| 519 | (let* ((sod-object (make-sod-class "SodObject" nil |
| 520 | (make-property-set :nick 'obj))) |
| 521 | (sod-class (make-sod-class "SodClass" (list sod-object) |
| 522 | (make-property-set :nick 'cls))) |
| 523 | (classes (list sod-object sod-class))) |
| 524 | |
| 525 | ;; Attach the built-in messages. |
| 526 | (make-sod-message sod-object "init" |
| 527 | (c-type (fun void :keys)) |
| 528 | (make-property-set |
| 529 | :message-class 'initialization-message)) |
| 530 | (make-sod-message sod-object "teardown" (c-type (fun int)) |
| 531 | (make-property-set :message-class 'teardown-message)) |
| 532 | |
| 533 | ;; Sort out the recursion. |
| 534 | (setf (slot-value sod-class 'chain-link) sod-object) |
| 535 | (dolist (class classes) |
| 536 | (setf (slot-value class 'metaclass) sod-class)) |
| 537 | |
| 538 | ;; Predeclare the class types. |
| 539 | (dolist (class classes) |
| 540 | (make-class-type (sod-class-name class))) |
| 541 | |
| 542 | ;; Attach the class slots. |
| 543 | (dolist (slot *class-slot-alist*) |
| 544 | (funcall (cdr slot) sod-class)) |
| 545 | |
| 546 | ;; These classes are too closely intertwined. We must partially finalize |
| 547 | ;; them together by hand. This is cloned from `finalize-sod-class'. |
| 548 | (dolist (class classes) |
| 549 | (with-slots (class-precedence-list chain-head chain chains) class |
| 550 | (setf class-precedence-list (compute-cpl class)) |
| 551 | (setf (values chain-head chain chains) (compute-chains class)))) |
| 552 | |
| 553 | ;; Done. |
| 554 | (dolist (class classes) |
| 555 | (unless (finalize-sod-class class) |
| 556 | (error "Failed to finalize built-in class")) |
| 557 | (add-to-module module class)))) |
| 558 | |
| 559 | (export '*builtin-module*) |
| 560 | (defvar-unbound *builtin-module* |
| 561 | "The builtin module.") |
| 562 | |
| 563 | (export 'make-builtin-module) |
| 564 | (defun make-builtin-module () |
| 565 | "Construct the builtin module. |
| 566 | |
| 567 | This involves constructing the braid (which is done in |
| 568 | `bootstrap-classes') and defining a few obvious type names which users |
| 569 | will find handy. |
| 570 | |
| 571 | Returns the newly constructed module, and stores it in the variable |
| 572 | `*builtin-module*'." |
| 573 | (let ((module (make-instance 'module |
| 574 | :name (make-pathname :name "SOD-BASE" |
| 575 | :type "SOD" |
| 576 | :case :common) |
| 577 | :state nil))) |
| 578 | (with-module-environment (module) |
| 579 | (flet ((header-name (name) |
| 580 | (concatenate 'string "\"" (string-downcase name) ".h\"")) |
| 581 | (add-includes (reason &rest names) |
| 582 | (let ((text (with-output-to-string (out) |
| 583 | (dolist (name names) |
| 584 | (format out "#include ~A~%" name))))) |
| 585 | (add-to-module module |
| 586 | (make-instance 'code-fragment-item |
| 587 | :reason reason |
| 588 | :constraints nil |
| 589 | :name :includes |
| 590 | :fragment text))))) |
| 591 | (add-includes :c (header-name "sod")) |
| 592 | (add-includes :h "<stddef.h>")) |
| 593 | (bootstrap-classes module)) |
| 594 | (setf *builtin-module* module))) |
| 595 | |
| 596 | (define-clear-the-decks builtin-module |
| 597 | (unless (boundp '*builtin-module*) (make-builtin-module))) |
| 598 | |
| 599 | ;;;----- That's all, folks -------------------------------------------------- |