[cffi-objects-cvs] r3 -

[rklochkov at common-lisp.net]

Author: rklochkov
Date: Fri May  4 04:25:20 2012
New Revision: 3

Log:
Fixes with GC

Modified:
   cffi-objects.asd
   freeable.lisp
   object.lisp
   package.lisp
   struct.lisp

Modified: cffi-objects.asd
==============================================================================
--- cffi-objects.asd	Mon Feb 20 10:55:20 2012	(r2)
+++ cffi-objects.asd	Fri May  4 04:25:20 2012	(r3)
@@ -17,7 +17,7 @@
   :depends-on (cffi trivial-garbage)
   :components
   ((:file package)
-   (:file redefines :depends-on (package))
+   (:file redefines :depends-on (package freeable))
    (:file freeable :depends-on (package))
    (:file object :depends-on (freeable))
    (:file pfunction :depends-on (package))

Modified: freeable.lisp
==============================================================================
--- freeable.lisp	Mon Feb 20 10:55:20 2012	(r2)
+++ freeable.lisp	Fri May  4 04:25:20 2012	(r3)
@@ -27,10 +27,12 @@
 
 (defgeneric free-sent-ptr (type ptr)
   (:method ((type freeable-base) ptr)
+    (format t "Free-sent-ptr: ~a ~a ~%" type ptr)
     (free-ptr type ptr)))
 
 (defgeneric free-returned-ptr (type ptr)
   (:method ((type freeable-base) ptr)
+    (format t "Free-returned-ptr: ~a ~a ~%" type ptr)
     (free-ptr type ptr)))
 
 (defun free-sent-if-needed (type ptr)

Modified: object.lisp
==============================================================================
--- object.lisp	Mon Feb 20 10:55:20 2012	(r2)
+++ object.lisp	Fri May  4 04:25:20 2012	(r3)
@@ -31,7 +31,9 @@
   (tg:cancel-finalization object)
   (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
     (let ((class (class-of object)))
-      (tg:finalize object (lambda () 
+      (format t "Set finalizer: ~a ~a ~a~%" object class value)
+      (tg:finalize object (lambda ()
+                            (format t "Finalize: ~a ~a~%" class value)
                             (free-ptr class value)))))
                                         ; specialize EQL CLASS to override
   (unless (or (volatile object) (null-pointer-p value))
@@ -77,7 +79,7 @@
 If not found or found with wrong class, create new one with given CLASS"
   (declare (type symbol class) (type foreign-pointer pointer))
   (unless (null-pointer-p pointer)
-    (let  ((try-find (gethash (pointer-address pointer) *objects*)))
+    (let ((try-find (gethash (pointer-address pointer) *objects*)))
       (if class
           (progn
             (unless (or (null try-find)
@@ -85,7 +87,9 @@
               (progn
                 (free try-find)
                 (setf try-find nil)))
-            (or try-find (make-instance class :pointer pointer)))
+            (or try-find (make-instance class 
+                                        :pointer pointer 
+                                        :free-after nil)))
         try-find))))
 
 (defun object-by-id (id-key)
@@ -117,6 +121,12 @@
                                  (type cffi::foreign-pointer-type))
   (null-pointer))
 
+;; nil = null string
+(defmethod translate-to-foreign ((value null)
+                                 (type cffi::foreign-string-type))
+  (null-pointer))
+
+
 (defmethod translate-to-foreign (value (type cffi-object))
   (check-type value foreign-pointer)
   value)

Modified: package.lisp
==============================================================================
--- package.lisp	Mon Feb 20 10:55:20 2012	(r2)
+++ package.lisp	Fri May  4 04:25:20 2012	(r3)
@@ -21,6 +21,7 @@
    #:gconstructor
 
    #:object
+   #:free-after
    #:find-object
    #:object-by-id
    #:*objects*

Modified: struct.lisp
==============================================================================
--- struct.lisp	Mon Feb 20 10:55:20 2012	(r2)
+++ struct.lisp	Fri May  4 04:25:20 2012	(r3)
@@ -142,7 +142,7 @@
   (struct->clos (object-class type) value))
 
 ;;; Allowed use with object designator
-;; object == (struct nil :out t :free t)
+;; object == (struct nil)
 
 
 ;; to allow using array of structs