From 58f6e932d5824de496c28fe628854ef4025d4191 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sat, 4 Aug 2007 01:32:22 +0200
Subject: Add memory management for Objective C objects.

darcs-hash:d5d6b0355b5224562fceb3a66920da3071afcfb1
---
 objcl.lisp | 57 ++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 48 insertions(+), 9 deletions(-)

diff --git a/objcl.lisp b/objcl.lisp
index ee8446e..1684ba0 100644
--- a/objcl.lisp
+++ b/objcl.lisp
@@ -28,7 +28,7 @@
 
 (defclass c-pointer-wrapper ()
   ((pointer :type     c-pointer
-            :accessor pointer-to
+            :reader   pointer-to
             :initarg  :pointer)))
 
 
@@ -53,6 +53,32 @@
                       (objcl-invoke-class-method condition "reason")
                       "UTF8String")))))
 
+(defvar *skip-finalization* nil)
+(defvar *skip-retaining*    nil)
+
+;; We call the `retain' method on every object that is garbage collected
+;; on our side.  Upon finalization, wie `release' it.
+(eval-when (:load-toplevel)
+  (dolist (type '(objc-id objc-class objc-exception))
+    (funcall
+     (compile nil
+              `(lambda ()
+                 (defmethod initialize-instance ((obj ,type) &key)
+                   (call-next-method)
+                   (unless *skip-retaining*
+                     (let ((*skip-retaining* t))
+                       (objcl-invoke-class-method obj "retain")))
+                   (unless *skip-finalization*
+                     (assert (not (null (pointer-to obj))))
+                     (let ((saved-pointer (pointer-to obj))
+                           (saved-type    (type-of obj)))
+                       (flet ((finalizer ()
+                                (let ((temp (let ((*skip-finalization* t))
+                                              (make-instance saved-type
+                                                             :pointer saved-pointer))))
+                                  (objcl-invoke-class-method temp "release"))))
+                         (trivial-garbage:finalize obj #'finalizer))))))))))
+
 
 (defgeneric objcl-eql (obj1 obj2))
 (defmethod objcl-eql ((obj1 c-pointer-wrapper) (obj2 c-pointer-wrapper))
@@ -246,6 +272,7 @@
           arglist))
 
 
+#+nil
 (defun objcl-invoke-instance-method (receiver method-name &rest args)
   (let* ((arglist (arglist-intersperse-types
                    (mapcar #'lisp->obj-data args)))
@@ -259,6 +286,18 @@
       (dealloc-obj-data return-value))))
 
 
+(defun constructor-name-p (method-name)
+  (flet ((method-name-starts-with (prefix)
+           (and (>= (length method-name) (length prefix))
+                (or (and (string= prefix
+                                  (subseq method-name 0 (length prefix)))
+                         (or (= (length method-name)
+                                (length prefix))
+                             (not (lower-case-p (char method-name (length prefix))))))))))
+    (or (method-name-starts-with "alloc")
+        (method-name-starts-with "new"))))
+
+
 (defun objcl-invoke-class-method (class method-name &rest args)
   (let* ((arglist (arglist-intersperse-types
                    (mapcar #'lisp->obj-data args)))
@@ -267,14 +306,14 @@
                                     method-name
                                     (length args)
                                     arglist)))
-    (prog1
-        (let ((value (obj-data->lisp return-value)))
-          (if (typep value 'condition)
-              (cerror "Return NIL from OBJCL-INVOKE-CLASS-METHOD" value)
-              value))
-      #+nil (print (foreign-string-to-lisp (foreign-slot-value return-value
-                                                               'obj-data
-                                                               'type)))
+    (unwind-protect
+         (let ((value
+                (let ((*skip-retaining* (or *skip-retaining*
+                                            (constructor-name-p method-name))))
+                  (obj-data->lisp return-value))))
+           (if (typep value 'condition)
+               (cerror "Return NIL from OBJCL-INVOKE-CLASS-METHOD" value)
+               value))
       (dealloc-obj-data return-value))))
 
 
-- 
cgit v1.2.3