(sod-class-nickname tail))))
(ilayout-ichains ilayout)))))
-(define-class-slot "init" (class stream)
- (* (fun (* void) ("/*p*/" (* void))))
- (format nil "~A__init" class)
-
- ;; FIXME this needs a metaobject protocol
- (let ((ilayout (sod-class-ilayout class)))
- (format stream "~&~:
-/* Provide initial values for an instance's slots. */
-static void *~A__init(void *p)~%{~%" class)
- (dolist (ichain (ilayout-ichains ilayout))
- (let ((ich (format nil "sod__obj->~A.~A"
- (sod-class-nickname (ichain-head ichain))
- (sod-class-nickname (ichain-tail ichain)))))
- (dolist (item (ichain-body ichain))
- (etypecase item
- (vtable-pointer
- nil)
- (islots
- (let ((isl (format nil "~A.~A"
- ich
- (sod-class-nickname (islots-class item)))))
- (dolist (slot (islots-slots item))
- (let ((dslot (effective-slot-direct-slot slot))
- (init (effective-slot-initializer slot)))
- (when init
- (format stream " {~% ")
- (pprint-c-type (sod-slot-type dslot) stream
- *sod-tmp-val*)
- (format stream " = ~A;~% ~
- ~A.~A = ~A;~% ~
- }~%"
- (sod-initializer-value init)
- isl (sod-slot-name dslot)
- *sod-tmp-val*))))))))))
- (format stream "~&~:
- return (p);
-}~2%")))
-
;;;--------------------------------------------------------------------------
;;; Superclass structure.
"0"))
;;;--------------------------------------------------------------------------
+;;; Built-in methods.
+
+;; Common protocol.
+
+(defclass lifecycle-message (standard-message)
+ ())
+
+(defclass lifecycle-effective-method (standard-effective-method)
+ ())
+
+(defmethod effective-method-live-p ((method lifecycle-effective-method))
+ t)
+
+(defgeneric lifecycle-method-kernel (method codegen target)
+ (:documentation
+ "Compute (into CODEGEN) the class-specific part of the METHOD.
+
+ The result, if any, needs to find its way to the TARGET, as usual."))
+
+(defmethod simple-method-body
+ ((method lifecycle-effective-method) codegen target)
+ (invoke-delegation-chain codegen target
+ (effective-method-basic-argument-names method)
+ (effective-method-primary-methods method)
+ (lambda (target)
+ (lifecycle-method-kernel method
+ codegen
+ target))))
+
+;; Initialization.
+
+(defclass initialization-message (lifecycle-message)
+ ())
+
+(defclass initialization-effective-method (lifecycle-effective-method)
+ ())
+
+(defmethod sod-message-effective-method-class
+ ((message initialization-message))
+ 'initialization-effective-method)
+
+(defmethod lifecycle-method-kernel
+ ((method initialization-effective-method) codegen target)
+ (let* ((class (effective-method-class method))
+ (ilayout (sod-class-ilayout class))
+ (obj-tag (ilayout-struct-tag class))
+ (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
+ (func-name (format nil "~A__init" class)))
+
+ ;; Start building the initialization function.
+ (codegen-push codegen)
+
+ (labels ((set-from-initializer (var type init)
+ ;; Store the value of INIT, which has the given TYPE, in VAR.
+ ;; INIT has the syntax of an initializer: declare and
+ ;; initialize a temporary, and then copy the result.
+ ;; Compilers seem to optimize this properly. Return the
+ ;; resulting code as an instruction.
+ (codegen-push codegen)
+ (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
+ (deliver-expr codegen var *sod-tmp-val*)
+ (codegen-pop-block codegen)))
+
+ ;; Loop over the instance layout emitting initializers as we find them.
+ (dolist (ichain (ilayout-ichains ilayout))
+ (let ((ich (format nil "sod__obj->~A.~A"
+ (sod-class-nickname (ichain-head ichain))
+ (sod-class-nickname (ichain-tail ichain)))))
+ (dolist (item (ichain-body ichain))
+ (etypecase item
+ (vtable-pointer
+ nil)
+ (islots
+ (let ((isl (format nil "~A.~A"
+ ich
+ (sod-class-nickname (islots-class item)))))
+ (dolist (slot (islots-slots item))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot)))
+ (when init
+ (let* ((slot-type (sod-slot-type dslot))
+ (slot-default (sod-initializer-value init))
+ (target (format nil "~A.~A"
+ isl (sod-slot-name dslot)))
+ (initinst (set-from-initializer target
+ slot-type
+ slot-default)))
+ (emit-inst codegen initinst))))))))))))
+
+ ;; Done making the initialization function.
+ (codegen-pop-function codegen func-name func-type
+ "Instance initialization function ~:_~
+ for class `~A'."
+ class)
+
+ (deliver-call codegen :void func-name "sod__obj")))
+
+;;;--------------------------------------------------------------------------
;;; Bootstrapping the class graph.
(defun bootstrap-classes (module)
(make-property-set :nick 'cls)))
(classes (list sod-object sod-class)))
+ ;; Attach the built-in messages.
+ (make-sod-message sod-object "init"
+ (c-type (fun void :keys))
+ (make-property-set
+ :message-class 'initialization-message))
+
;; Sort out the recursion.
(setf (slot-value sod-class 'chain-link) sod-object)
(dolist (class classes)
~mdw / sod / blobdiff