+;;; 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))))
+
+;; Utilities.
+
+(defun declare-me (codegen class)
+ "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS.
+
+ The pointer refers to a part of the prevailing `sod__obj' object, which is
+ assumed to be a pointer to an appropriate `ilayout' structure."
+ (emit-decl codegen (make-var-inst "me" (c-type (* (class class)))
+ (format nil "&sod__obj->~A.~A"
+ (sod-class-nickname
+ (sod-class-chain-head class))
+ (sod-class-nickname class)))))
+
+;; 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)))
+
+ ;; Initialize the structure defined by the various superclasses, in
+ ;; reverse precedence order.
+ (dolist (super (reverse (sod-class-precedence-list class)))
+ (let* ((ichain (find (sod-class-chain-head super)
+ (ilayout-ichains ilayout)
+ :key #'ichain-head))
+ (islots (find super (ichain-body ichain)
+ :test (lambda (class item)
+ (and (typep item 'islots)
+ (eq (islots-class item) class)))))
+ (frags (sod-class-initfrags super))
+ (this-class-focussed-p nil)
+ (isl (format nil "me->~A" (sod-class-nickname super))))
+
+ (flet ((focus-this-class ()
+ ;; Delayed initial preparation. Don't bother defining the
+ ;; `me' pointer if there's actually nothing to do.
+ (unless this-class-focussed-p
+ (emit-banner codegen
+ "Initialization for class `~A'." super)
+ (codegen-push codegen)
+ (declare-me codegen super)
+ (setf this-class-focussed-p t))))
+
+ ;; Work through each slot in turn.
+ (dolist (slot (and islots (islots-slots islots)))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot)))
+ (when init
+ (focus-this-class)
+ (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)))))
+
+ ;; Emit the class's initialization fragments.
+ (when frags
+ (let ((used-me-p this-class-focussed-p))
+ (focus-this-class)
+ (unless used-me-p
+ (deliver-call codegen :void "SOD__IGNORE" "me")))
+ (dolist (frag frags)
+ (codegen-push codegen)
+ (emit-inst codegen frag)
+ (emit-inst codegen (codegen-pop-block codegen))))
+
+ ;; If we opened a block to initialize this class then close it
+ ;; again.
+ (when this-class-focussed-p
+ (emit-inst codegen (codegen-pop-block codegen)))))))
+
+ ;; 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")))
+
+;; Teardown.
+
+(defclass teardown-message (lifecycle-message)
+ ())
+
+(defclass teardown-effective-method (lifecycle-effective-method)
+ ())
+
+(defmethod sod-message-effective-method-class ((message teardown-message))
+ 'teardown-effective-method)
+
+(defmethod lifecycle-method-kernel
+ ((method teardown-effective-method) codegen target)
+ (let* ((class (effective-method-class method))
+ (obj-tag (ilayout-struct-tag class))
+ (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
+ (func-name (format nil "~A__teardown" class)))
+ (codegen-push codegen)
+ (dolist (super (sod-class-precedence-list class))
+ (let ((frags (sod-class-tearfrags super)))
+ (when frags
+ (emit-banner codegen "Teardown for class `~A'." super)
+ (codegen-push codegen)
+ (declare-me codegen super)
+ (deliver-call codegen :void "SOD__IGNORE" "me")
+ (dolist (frag frags)
+ (codegen-push codegen)
+ (emit-inst codegen frag)
+ (emit-inst codegen (codegen-pop-block codegen)))
+ (emit-inst codegen (codegen-pop-block codegen)))))
+ (codegen-pop-function codegen func-name func-type
+ "Instance teardown function ~:_~
+ for class `~A'."
+ class)
+ (deliver-call codegen :void
+ (format nil "~A__teardown" class) "sod__obj")
+ (deliver-expr codegen target 0)))
+
+;;;--------------------------------------------------------------------------