[cffi-objects-cvs] r15 -

[rklochkov at common-lisp.net]

Author: rklochkov
Date: Mon Dec 24 17:10:43 2012
New Revision: 15

Log:
Added initargs

Added:
   README.md
Modified:
   array.lisp
   struct.lisp
   tests.lisp

Added: README.md
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ README.md	Mon Dec 24 17:10:43 2012	(r15)
@@ -0,0 +1,5 @@
+CFFI-objects is a library, that enhances CFFI with several new constructions to use when you need to work with complex structures or objects.
+
+It supports structures by-value and by-reference with and without saving C-pointer on lisp side. Also there is type pobject, that allows to send lisp object with pointer slot or C-pointer. No verbose documentation yet, sorry.
+
+License is BSD

Modified: array.lisp
==============================================================================
--- array.lisp	Sat Dec 22 22:59:28 2012	(r14)
+++ array.lisp	Mon Dec 24 17:10:43 2012	(r15)
@@ -34,8 +34,9 @@
            (type (element-type cffi-array)))
       (if (struct-p type)
           (dotimes (i array-length res)
-            (setf (aref res i) (convert-from-foreign (mem-aptr ptr type i)
-                                                     type)))
+            (setf (aref res i) (convert-from-foreign 
+                                (mem-aptr ptr (list :struct (second type)) i)
+                                type)))
           (dotimes (i array-length res)
             (setf (aref res i) (mem-aref ptr type i)))))))
 

Modified: struct.lisp
==============================================================================
--- struct.lisp	Sat Dec 22 22:59:28 2012	(r14)
+++ struct.lisp	Mon Dec 24 17:10:43 2012	(r15)
@@ -16,7 +16,7 @@
 
 (defgeneric new-struct (class)
   (:method (class)
-    (foreign-alloc class)))        
+    (foreign-alloc class)))
 
 (defgeneric free-struct (class value)
   (:method (class value)
@@ -25,13 +25,24 @@
     ;(format t "Free ~a ~a~%" class value)
     (foreign-free value)))
 
-(defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys)
-  (if new-struct 
-      (new-struct (class-name (class-of struct)))
-      (progn 
-        (setf (slot-value struct 'value) nil)
-        (setf (slot-value struct 'free-after) nil)
-        (null-pointer))))
+(defmethod gconstructor ((struct struct) &rest initargs 
+                         &key new-struct &allow-other-keys)
+  (let ((class-name (class-name (class-of struct)))
+        (pointer (null-pointer)))
+    (if new-struct 
+        (setf pointer (new-struct class-name))
+        (progn 
+          (setf (slot-value struct 'value) nil
+                (slot-value struct 'free-after) nil)))
+    (mapc
+     (lambda (field) 
+       (let ((val (getf initargs (alexandria:make-keyword field))))
+         (if new-struct
+             (setf (foreign-slot-value pointer 
+                                       (list :struct class-name) field) val)
+             (setf (getf (slot-value struct 'value) field) val))))
+     (foreign-slot-names (list :struct class-name)))
+    pointer))
 
 (defun pair (maybe-pair)
   (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
@@ -102,9 +113,11 @@
 
 (defun clos->new-struct (class object)
   (if (slot-boundp object 'value)
-      (let ((res (new-struct class)))
-        (clos->struct class object res)
-        res)
+      ;; use make-instance, not new-struct, because gconstructor
+      ;;                                            may be redefined
+      (let ((res (make-instance class :new-struct t)))
+        (clos->struct class object (pointer res))
+        (pointer res))
       (pointer object)))
 
 (defun struct->clos (class struct &optional object)

Modified: tests.lisp
==============================================================================
--- tests.lisp	Sat Dec 22 22:59:28 2012	(r14)
+++ tests.lisp	Mon Dec 24 17:10:43 2012	(r15)
@@ -10,18 +10,22 @@
 (defcstruct* test
   (x :int))
 
-(deftest test.carray ()
+(deftest test.struct ()
   (is (= (let ((obj (make-instance 'test)))
            (setf (x obj) 1)
            (x obj)) 1))
+  (is (= 1 (x (make-instance 'test :x 1)))))  
+
+(deftest test.carray ()
   (let ((obj (make-array 10)))
     (dotimes (i 10)
       (setf (aref obj i) 
             (let ((struct (make-instance 'test)))
               (setf (x struct) i)
               struct)))
+    (setf (mem-ref *array-length* :int) 10)
     (is (every (lambda (a b) (= (x a) (x b)))
                obj
                (convert-from-foreign 
                 (convert-to-foreign obj '(carray (struct test)))
-                '(carray (struct test)))))))
\ No newline at end of file
+                '(carray (struct test)))))))