From 447f9c1af0096f52555eb6d3d5ee758707f8cfd9 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 15 Feb 2008 18:52:09 +0100
Subject: Add automatic finalisation to struct wrappers.

darcs-hash:1e1b7811aa26338c747a031d3cf810f621cf12d9
---
 Lisp/data-types.lisp | 18 +++++++++++-------
 Lisp/libobjcl.lisp   | 15 +++++++++++++++
 2 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 1b2beb7..4360ca5 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -178,7 +178,7 @@ a suitable class method instead as you would in Objective-C.
 
 (define-condition exception (error)
     ((pointer :type     c-pointer
-              :accessor pointer-to
+              :reader   pointer-to
               :initarg  :pointer))
   (:report (lambda (condition stream)
              (format stream
@@ -256,12 +256,16 @@ an __exception__, you can simply send it the `self' message.
 
 
 (defun make-struct-wrapper (pointer typespec managedp)
-  (make-instance (ecase (typespec-primary-type typespec)
-                   (struct 'tagged-struct)
-                   (union 'tagged-union))
-     :typespec typespec
-     :pointer pointer
-     :lisp-managed managedp))
+  (let ((new-wrapper (make-instance (ecase (typespec-primary-type typespec)
+                                      (struct 'tagged-struct)
+                                      (union 'tagged-union))
+                        :typespec typespec
+                        :pointer pointer
+                        :lisp-managed managedp)))
+    (when managedp
+      (trivial-garbage:finalize new-wrapper
+                                #'(lambda ()
+                                    (foreign-free pointer))))))
 
 
 (defgeneric objcl-eql (obj1 obj2))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 89930b8..7c5fd8c 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -301,6 +301,21 @@ conventional case for namespace identifiers in Objective-C."
                                                class-name-string))
                                   :pointer class-ptr
                                   :wrapped-foreign-class class-name-string
+                                  ;; FIXME: It might be desirable to do
+                                  ;; set the list of direct superclasses
+                                  ;; to something like the following:
+                                  ;;
+                                  ;;  (if (string= class-name-string "NSException")
+                                  ;;      (list superclass (find-class 'serious-condition))
+                                  ;;      (list superclass))
+                                  ;;
+                                  ;; This will fail, as subclassing
+                                  ;; CONDITION means not subclassing a
+                                  ;; STANDARD-CLASS.  Also, care would
+                                  ;; have to be taken not to use
+                                  ;; MAKE-INSTANCE but MAKE-CONDITION
+                                  ;; for anything derived from
+                                  ;; NSException.
                                   :direct-superclasses (list superclass)))))))
 
 
-- 
cgit v1.2.3