[cffi-objects-cvs] r4 -

[rklochkov at common-lisp.net]

Author: rklochkov
Date: Mon May  7 10:27:22 2012
New Revision: 4

Log:
Minor fixes

Modified:
   freeable.lisp
   object.lisp
   struct.lisp

Modified: freeable.lisp
==============================================================================
--- freeable.lisp	Fri May  4 04:25:20 2012	(r3)
+++ freeable.lisp	Mon May  7 10:27:22 2012	(r4)
@@ -9,10 +9,10 @@
 
 (define-foreign-type freeable-base ()
   ((free :accessor object-free :initarg :free :initform :no-transfer
-         :type (member :none :all :no-transfer :transfer :container)
+         :type (member nil :none t :all :no-transfer :transfer :container)
          :documentation "Free returned or sent value.
-:NONE -- no free at all
-:ALL -- free always (after sending to FFI, or after recieved translation)
+:NONE, nil -- no free at all
+:ALL, t -- free always (after sending to FFI, or after recieved translation)
 :TRANSFER -- client frees, so free after recieve
 :NO-TRANSFER -- host frees, so free after sending to FFI.
 :CONTAINER -- the object is a container, ALL for container and NO-TRANSFER for
@@ -28,19 +28,21 @@
 (defgeneric free-sent-ptr (type ptr)
   (:method ((type freeable-base) ptr)
     (format t "Free-sent-ptr: ~a ~a ~%" type ptr)
-    (free-ptr type ptr)))
+    (unless (null-pointer-p 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)))
+    (unless (null-pointer-p ptr)
+      (free-ptr type ptr))))
 
 (defun free-sent-if-needed (type ptr)
-  (when (member (object-free type) '(:all :container :no-transfer))
+  (when (member (object-free type) '(t :all :container :no-transfer))
     (free-sent-ptr type ptr)))
 
 (defun free-returned-if-needed (type ptr)
-  (when (member (object-free type) '(:all :container :transfer))
+  (when (member (object-free type) '(t :all :container :transfer))
     (free-returned-ptr type ptr)))
 
 (defclass freeable (freeable-base) ()

Modified: object.lisp
==============================================================================
--- object.lisp	Fri May  4 04:25:20 2012	(r3)
+++ object.lisp	Mon May  7 10:27:22 2012	(r4)
@@ -90,7 +90,7 @@
             (or try-find (make-instance class 
                                         :pointer pointer 
                                         :free-after nil)))
-        try-find))))
+        (or try-find pointer)))))
 
 (defun object-by-id (id-key)
   (gethash id-key *objects-ids*))

Modified: struct.lisp
==============================================================================
--- struct.lisp	Fri May  4 04:25:20 2012	(r3)
+++ struct.lisp	Mon May  7 10:27:22 2012	(r4)
@@ -99,16 +99,24 @@
                     (setf (foreign-slot-value res class slot) val))))
               (foreign-slot-names class))
         res)
-      (slot-value object 'pointer)))
+      (pointer object)))
 
 (defun struct->clos (class struct &optional object)
-  (let ((res (or object (make-instance class))))
-    (setf (slot-value res 'value) nil)
-    (mapc (lambda (slot)
-            (setf (getf (slot-value res 'value) slot) 
-                  (foreign-slot-value struct class slot)))                  
-          (foreign-slot-names class))
-    res))
+  (unless object
+    (return-from struct->clos
+      (unless (null-pointer-p struct)
+        (make-instance class :pointer struct))))  
+  (if (slot-boundp object 'value)
+      (progn
+        (setf (slot-value object 'value) nil)
+        (mapc (lambda (slot)
+                (setf (getf (slot-value object 'value) slot) 
+                      (foreign-slot-value struct class slot)))
+              (foreign-slot-names class)))
+      (setf (pointer object) struct))
+  ;(break)
+  object)
+