[gtk-cffi-cvs] CVS gtk-cffi/cffi

[CVS User rklochkov]

Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi
In directory tiger.common-lisp.net:/tmp/cvs-serv13474/cffi

Modified Files:
	object.lisp 
Log Message:
Refactored defslots/def*funs



--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp	2011/12/31 17:20:56	1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/object.lisp	2012/01/21 18:35:00	1.7
@@ -19,6 +19,7 @@
    ;; by default object shouldn't be stored unless it is GtkObject
    (volatile :type boolean :accessor volatile 
              :initarg :volatile :initform t)
+   (free-after :type boolean :initarg :free-after :initform t)
    (id :type symbol :accessor id :initarg :id :initform nil))
   (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
 shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
@@ -26,8 +27,9 @@
 (defmethod (setf pointer) :after (value (object object))
   (declare (type foreign-pointer value))
   (tg:cancel-finalization object)
-  (when (and (volatile object) (not (null-pointer-p value)))
-    (tg:finalize object (lambda () (foreign-free value))))
+  (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
+    (tg:finalize object (lambda () 
+                          (foreign-free value))))
   (unless (or (volatile object) (null-pointer-p value))
     (setf (gethash (pointer-address value) *objects*) object)
     (when (id object)
@@ -47,7 +49,7 @@
 (defmethod shared-initialize :after ((object object) slot-names 
                               &rest initargs
                               &key pointer &allow-other-keys)
-  (unless pointer 
+  (unless pointer
     (setf (pointer object) (apply #'gconstructor object initargs))))
 
 (defmethod pointer (something-bad)