From 1f4b75e92f6399ec545140ef3d6afe7644f1e6eb Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sat, 4 Aug 2007 02:54:43 +0200
Subject: Save Objective C references in global hash tables for reuse.

darcs-hash:782a93dbfe144036611aa358f7a108b0ff1532a9
---
 libobjcl.m |  5 +++--
 objcl.lisp | 69 ++++++++++++++++++++++++++++++++++++++++++++------------------
 2 files changed, 52 insertions(+), 22 deletions(-)

diff --git a/libobjcl.m b/libobjcl.m
index a32ea1f..41d165c 100644
--- a/libobjcl.m
+++ b/libobjcl.m
@@ -178,7 +178,7 @@ objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver,
 
   NS_DURING
     {
-      fprintf (stderr, "! ---------> %s <--------\n", receiver->type);
+      /* fprintf (stderr, "! ---------> %s <--------\n", receiver->type); */
       assert (receiver->type[0] == '#'
               || receiver->type[0] == '@'
               || receiver->type[0] == 'E');
@@ -225,6 +225,7 @@ objcl_invoke_class_method (OBJCL_OBJ_DATA class,
 
   NS_DURING
     {
+      /* fprintf (stderr, "? ---------> %s <--------\n", class->type); */
       assert (class->type[0] == '#'
               || class->type[0] == '@'
               || class->type[0] == 'E');
@@ -278,7 +279,7 @@ objcl_class_name (OBJCL_OBJ_DATA class)
 {
   Class cls = NULL;
 
-  fprintf (stderr, "---------> %s <--------\n", class->type);
+  /* fprintf (stderr, "---------> %s <--------\n", class->type); */
   fflush (stderr);
   assert (class->type[0] == '#'
           || class->type[0] == '@'
diff --git a/objcl.lisp b/objcl.lisp
index 1684ba0..7027bd1 100644
--- a/objcl.lisp
+++ b/objcl.lisp
@@ -29,7 +29,8 @@
 (defclass c-pointer-wrapper ()
   ((pointer :type     c-pointer
             :reader   pointer-to
-            :initarg  :pointer)))
+            :initarg  :pointer
+            :initform nil)))
 
 
 (defclass objc-selector (c-pointer-wrapper) ())
@@ -56,28 +57,57 @@
 (defvar *skip-finalization* nil)
 (defvar *skip-retaining*    nil)
 
+(defvar *id-objects*
+  (trivial-garbage:make-weak-hash-table :weakness :value
+                                        :test 'eql))
+
+(defvar *class-objects*
+  (trivial-garbage:make-weak-hash-table :weakness :value
+                                        :test 'eql))
+
+(defvar *exception-objects*
+  (trivial-garbage:make-weak-hash-table :weakness :value
+                                        :test 'eql))
+
 ;; 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))))))))))
+     (compile
+      nil
+      `(lambda ()
+         (defmethod make-instance ((class (eql ',type)) &rest initargs &key)
+           (let* ((hash-table ,(case type
+                                 ((objc-id)        '*id-objects*)
+                                 ((objc-class)     '*class-objects*)
+                                 ((objc-exception) '*exception-objects*)))
+                  (hash-key (pointer-address (getf initargs :pointer)))
+                  (obj (gethash hash-key hash-table nil)))
+             (typecase obj
+               (keyword (assert (eq :incomplete obj))
+                        (call-next-method))
+               (null (setf (gethash hash-key hash-table)
+                           :incomplete)
+                     (let ((new-obj (call-next-method)))
+                       (setf (gethash hash-key hash-table) new-obj)
+                       (unless *skip-retaining*
+                         (objcl-invoke-class-method new-obj "retain"))
+                       (unless *skip-finalization*
+                         (assert (not (null (pointer-to new-obj))))
+                         (let ((saved-pointer (pointer-to new-obj))
+                               (saved-type    (type-of new-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 new-obj #'finalizer))))
+                       new-obj))
+               (t obj))))
+
+         (defmethod initialize-instance ((obj ,type) &key)
+           (call-next-method)))))))
 
 
 (defgeneric objcl-eql (obj1 obj2))
@@ -330,8 +360,7 @@
               (string    (foreign-string-alloc value))
               (otherwise value)))
       (setf type
-            (foreign-string-alloc (type-name->type-id type-name)))
-      #+nil (print (foreign-string-to-lisp type)))
+            (foreign-string-alloc (type-name->type-id type-name))))
     obj-data))
 
 
-- 
cgit v1.2.3