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 ++++-
 3 files changed, 44 insertions(+), 1 deletion(-)
 create mode 100644 Lisp/instance-management.lisp

(limited to '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*)
-- 
cgit v1.2.3