New feature: proper object lifecycle protocol; init and teardown fragments.

[sod] / src / builtin.lisp

diff --git a/src/builtin.lisp b/src/builtin.lisp
index ffd8451..d7d0fcb 100644 (file)
--- a/src/builtin.lisp
+++ b/src/builtin.lisp
@@ -290,6 +290,7 @@ static const SodClass *const ~A__cpl[] = {
                             :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))))
 
@@ -318,6 +319,17 @@ static const SodClass *const ~A__cpl[] = {
                                                         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
@@ -331,6 +343,44 @@ static const SodClass *const ~A__cpl[] = {
 
     (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)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Bootstrapping the class graph.
 
@@ -351,6 +401,8 @@ static const SodClass *const ~A__cpl[] = {
                      (c-type (fun void :keys))
                      (make-property-set
                       :message-class 'initialization-message))
+    (make-sod-message sod-object "teardown" (c-type (fun int))
+                     (make-property-set :message-class 'teardown-message))
 
     ;; Sort out the recursion.
     (setf (slot-value sod-class 'chain-link) sod-object)