From c61f86dce1eb244fb775e74043070e32e6fdcaaf Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sat, 16 Feb 2008 21:58:48 +0100
Subject: Add module: instance-management.

darcs-hash:79549f0b837006321061a524ad376df397a9ab5a
---
 Lisp/instance-management.lisp | 32 ++++++++++++++++++++++++++++++++
 Lisp/libobjcl.lisp            |  8 ++++++++
 Lisp/memory-management.lisp   |  5 ++++-
 Objective-C/libobjcl.h        |  3 +++
 Objective-C/libobjcl.m        |  7 +++++++
 objective-cl.asd              |  4 ++++
 6 files changed, 58 insertions(+), 1 deletion(-)
 create mode 100644 Lisp/instance-management.lisp

diff --git a/Lisp/instance-management.lisp b/Lisp/instance-management.lisp
new file mode 100644
index 0000000..c8abb44
--- /dev/null
+++ b/Lisp/instance-management.lisp
@@ -0,0 +1,32 @@
+;;;; Objective-CL, an Objective-C bridge for Common Lisp.
+;;;; Copyright (C) 2007, 2008  Matthias Andreas Benkard.
+;;;;
+;;;; This program is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public License
+;;;; as published by the Free Software Foundation, either version 3 of
+;;;; the License, or (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful, but
+;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this program.  If not, see
+;;;; <http://www.gnu.org/licenses/>.
+
+(in-package #:mulk.objective-cl)
+
+
+(defvar *lisp-managed-instances* (make-hash-table :test 'eql))
+
+(defun intern-lisp-managed-foreign-instance (&rest initargs &key pointer)
+  (let ((key (cffi:pointer-address pointer)))
+    (or (gethash key *lisp-managed-instances* nil)
+        (apply #'make-instance
+               (intern-pointer-wrapper (%objcl-object-get-class pointer))
+               initargs))))
+
+(defun unintern-lisp-managed-foreign-instance (instance)
+  (remhash (cffi:pointer-address (pointer-to instance))
+           *lisp-managed-instances*))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 8cb490b..da85f31 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -167,6 +167,11 @@
   (class :pointer)
   (backed-p :int))
 
+(defcfun ("objcl_object_backed_by_lisp_class_p"
+          %objcl-object-backed-by-lisp-class-p)
+    :int
+  (class :pointer))
+
 (defcvar *objcl-current-exception-lock* :pointer)
 (defcvar *objcl-current-exception* :pointer)
 
@@ -884,3 +889,6 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
 
 (defun objcl-class-set-backed-by-lisp-class/pointer (class-ptr backed-p)
   (%objcl-class-set-backed-by-lisp-class class-ptr (if backed-p 1 0)))
+
+(defun objcl-object-backed-by-lisp-class-p/pointer (object-ptr)
+  (not (zerop (%objcl-object-backed-by-lisp-class-p object-ptr))))
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 3d4685d..b625b8f 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -37,7 +37,10 @@
              (find-objc-meta-class-by-name (%objcl-class-name pointer))))
           ((%objcl-object-is-class pointer)
            (return-from intern-pointer-wrapper
-             (find-objc-class-by-name (%objcl-class-name pointer))))))
+             (find-objc-class-by-name (%objcl-class-name pointer))))
+          ((objcl-object-backed-by-lisp-class-p/pointer pointer)
+           (return-from intern-pointer-wrapper
+             (apply #'intern-lisp-managed-foreign-instance initargs)))))
   (let* ((hash-table (ecase class
                        ((id) *id-objects*)
                        ((exception) *exception-objects*)
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 26dca23..4b26fae 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -193,3 +193,6 @@ objcl_class_backed_by_lisp_class_p (Class class);
 
 void
 objcl_class_set_backed_by_lisp_class (Class class, int backed_p);
+
+int
+objcl_object_backed_by_lisp_class_p (id object);
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 141c069..cd35b86 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -797,3 +797,10 @@ objcl_class_set_backed_by_lisp_class (Class class, int backed_p)
 {
   [class __objcl_setBackedByLispClass: backed_p];
 }
+
+
+int
+objcl_object_backed_by_lisp_class_p (id object)
+{
+  return [[object class] __objcl_isBackedByLispClass];
+}
diff --git a/objective-cl.asd b/objective-cl.asd
index 9420f95..d595746 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -80,6 +80,10 @@
                                                           "init"
                                                           "method-invocation"
                                                           "data-types"))
+                 (:file "instance-management" :depends-on ("defpackage"
+                                                           "libobjcl"
+                                                           "init"
+                                                           "method-invocation"))
                  (:file "compiler-macros"    :depends-on ("defpackage"
                                                           "method-invocation"
                                                           "conditions")))))
-- 
cgit v1.2.3