From rklochkov at common-lisp.net  Sat Dec 22 19:24:45 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Sat, 22 Dec 2012 11:24:45 -0800
Subject: [cffi-objects-cvs] r13 -
Message-ID: <E1TmUgf-0004ia-UB@common-lisp.net>

Author: rklochkov
Date: Sat Dec 22 11:24:45 2012
New Revision: 13

Log:
Fixed array. Removed redefinition of cffi:mem-ref

Modified:
   array.lisp
   cffi-objects.asd
   freeable.lisp
   package.lisp
   redefines.lisp
   struct.lisp

Modified: array.lisp
==============================================================================
--- array.lisp	Sun Oct  7 04:59:54 2012	(r12)
+++ array.lisp	Sat Dec 22 11:24:45 2012	(r13)
@@ -22,17 +22,22 @@
       (let* ((length (length value))
              (type (element-type cffi-array))
              (res (foreign-alloc type :count length)))
-        (dotimes (i length (values res t))
-          (setf (mem-aref res type i) (elt value i)))
-        res)))
+        (if (struct-p type)
+            (dotimes (i length (values res t))
+              (clos->struct (second type) (elt value i) (mem-aptr res type i)))
+            (dotimes (i length (values res t))
+              (setf (mem-aref res type i) (elt value i)))))))
 
 (defmethod translate-from-foreign (ptr (cffi-array cffi-array))
   (let ((array-length (mem-ref *array-length* :uint)))
     (let* ((res (make-array array-length))
-           (el-type (element-type cffi-array)))
-      (dotimes (i array-length)
-        (setf (aref res i) (mem-aref ptr el-type i)))
-      res)))
+           (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)))
+          (dotimes (i array-length res)
+            (setf (aref res i) (mem-aref ptr type i)))))))
 
 (define-foreign-type cffi-null-array (freeable)
   ((element-type :initarg :type :accessor element-type))
@@ -59,4 +64,5 @@
       (push (mem-aref ptr el-type i) res))
     (coerce (nreverse res) 'array)))
 
-(defctype string-array (null-array :string) "Zero-terminated string array")
\ No newline at end of file
+(defctype string-array (null-array :string) "Zero-terminated string array")
+

Modified: cffi-objects.asd
==============================================================================
--- cffi-objects.asd	Sun Oct  7 04:59:54 2012	(r12)
+++ cffi-objects.asd	Sat Dec 22 11:24:45 2012	(r13)
@@ -22,5 +22,13 @@
    (:file object :depends-on (freeable))
    (:file pfunction :depends-on (package))
    (:file setters :depends-on (package))
-   (:file array :depends-on (package))
+   (:file array :depends-on (struct))
    (:file struct :depends-on (object setters))))
+
+(defsystem cffi-objects.tests
+  :author "Roman Klochkov <monk at slavsoft.surgut.ru>"
+  :version "0.9"
+  :license "BSD"
+  :depends-on (cffi-objects hu.dwim.stefil)
+  :components
+  ((:file tests)))
\ No newline at end of file

Modified: freeable.lisp
==============================================================================
--- freeable.lisp	Sun Oct  7 04:59:54 2012	(r12)
+++ freeable.lisp	Sat Dec 22 11:24:45 2012	(r13)
@@ -1,58 +1,118 @@
-;;;; -*- Mode: lisp -*-
-;;;
-;;; freeable.lisp --- Interface for objects, that may be freed after use
-;;;
-;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
-;;;
+;;;;<author>Roman Klochkov, monk at slavsoft.surgut.ru</author>
+;;;; Base classes for freeable and changeable CFFI types
 
-(in-package #:cffi-objects)
+(in-package #:cffi-objects)    
+
+;;;[ [[* Memory freeing automation *]]
+
+#|<doc>
+Most of new CFFI types introduced in my library will live in the dynamic
+memory. There are different policies of memory control in different languages
+and libraries. Sometimes caller should clean memory (like in GTK), sometimes 
+callee. 
+
+In any case programmer should have possibility to say, if he would
+like to free memory after function call. For example, in GTK it is common
+for callback to return a newly-allocated string or structure, but in
+parameters responsibility to clean memory remains to caller.
+
+Another common option for any type is a flag, that it is out-paramter, 
+so value of it should be translated back before freeing,
+
+For uniformity with CFFI :string I chose :free-from-foreign and 
+:free-to-foreign boolean flags to show, when we want to free memory. By default
+"caller frees" model is used.
+|#
+
+;;;[ <class freeable-base>
+
+#|<doc> I divided freeable functional to two classes: 
+\begin{itemize}
+\item [[freeable-base]] introduces all necessary fields and handlers
+\item [[freeable]] have ready cffi-translator methods
+|#
 
 (define-foreign-type freeable-base ()
-   ;; Should we free after translating from foreign?
-   ((free-from-foreign :initarg :free-from-foreign
+  ;; Should we free after translating from foreign?
+  ((free-from-foreign :initarg :free-from-foreign
                       :reader fst-free-from-foreign-p
                       :initform nil :type boolean)
    ;; Should we free after translating to foreign?
-    (free-to-foreign :initarg :free-to-foreign
-                     :reader fst-free-to-foreign-p
-                     :initform t :type boolean)))
-
-;; You should call FREE-RETURNED-IF-NEEDED and FREE-SENT-IF-NEEDED in
-;; appropriate places of your CFFI translators")))
+   (free-to-foreign :initarg :free-to-foreign
+                    :reader fst-free-to-foreign-p
+                    :initform t :type boolean)))
+
+#|<doc> 
+Interface to [[freeable-base]] consists of three generics for describing,
+how to free particular type: [[free-ptr]], [[free-sent-ptr]] and 
+[[free-returned-ptr]], and two functions to use in CFFI translators:
+[[free-returned-if-needed]] and [[free-sent-if-needed]].
+|#
+
+;;;[ <generic free-ptr (type ptr)>
+
+#|<doc>
+This generic describes, how to free an object with CFFI type [[type]] and
+pointer [[ptr]]. As [[type]] should be a symbol, you should specialize
+this generic with EQL specifier if your objects shouldn't be freed with
+[[foreign-free].
+
+One can ask, why normal specializer by type of object and [[object] as
+a first parameter is not used. Such strange API is developed, 
+because [[free-ptr]] is used in [[trivial-garbage:finalize]] and in some 
+implementation (for example, SBCL) finalizer shouldn't have reference
+to finalized object.
+
+If you dislike it and you will not use finalizers, simply specialize or
+redefine [[free-sent-ptr]] and [[free-returned-ptr]]
+|#
 
 (defgeneric free-ptr (type ptr)
   (:documentation "Called to free ptr, unless overriden free-sent-ptr 
 or free-returned-ptr. TYPE should be specialized with EQL")
-  (:method (type ptr)
-    (foreign-free ptr)))
+  (:method (type ptr) (foreign-free ptr)))
+
+;;;[ <generic free-sent-ptr>
 
 (defgeneric free-sent-ptr (cffi-type ptr param)
   (:method ((cffi-type freeable-base) ptr param)
     (unless (null-pointer-p ptr)
       (free-ptr (type-of cffi-type) ptr))))
 
+;;;[ <generic free-returned-ptr>
+
 (defgeneric free-returned-ptr (cffi-type ptr)
   (:method ((cffi-type freeable-base) ptr)
     (unless (null-pointer-p ptr)
       (free-ptr (type-of cffi-type) ptr))))
 
+;;;[ <function free-sent-if-needed
+
 (defun free-sent-if-needed (cffi-type ptr param)
   (when (fst-free-to-foreign-p cffi-type)
     (free-sent-ptr cffi-type ptr param)))
 
+;;;[ <function free-returned-if-needed
+
 (defun free-returned-if-needed (cffi-type ptr)
   (when (fst-free-from-foreign-p cffi-type)
     (free-returned-ptr cffi-type ptr)))
 
+;;;[ <class freeable>
+
 (defclass freeable (freeable-base) ()
   (:documentation "Mixing to auto-set translators"))
 
+
+
 (defmethod free-translated-object :after (ptr (type freeable) param)
   (free-sent-if-needed type ptr param))
 
 (defmethod translate-from-foreign :after (ptr (type freeable))
   (free-returned-if-needed type ptr))
 
+;;;[ <class freeable-out>
+
 (define-foreign-type freeable-out (freeable)
   ((out :accessor object-out :initarg :out :initform nil
         :documentation "This is out param (for fill in foreign side)"))

Modified: package.lisp
==============================================================================
--- package.lisp	Sun Oct  7 04:59:54 2012	(r12)
+++ package.lisp	Sat Dec 22 11:24:45 2012	(r13)
@@ -1,14 +1,22 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
-;;;
-;;; package.lisp --- Package definition for cffi-object
-;;;
-;;; Copyright (C) 2007, Roman Klochkov <monk at slavsoft.surgut.ru>
-;;;
-;;; This library is a CFFI add-on, that support
-;;;    GLib/GObject/GDK/GTK and similar objects
+;;;;<title> CFFI-Objects</title>
+;;;;<author>Roman Klochkov, monk at slavsoft.surgut.ru</author>
+;;;;<date>2012</date>
+
+;;;; Package definition for cffi-objects, 
+;;;; that is a CFFI add-on, supporting GLib/GObject/GDK/GTK and similar objects
+
+;;;<insert name="introduction"/>
+
+;;;[ [[* Package definition *]]
 
 (in-package #:cl-user)
 
+#|<doc>
+We unexport all symbols before [[defpackage]], because
+CFFI-objects will be a drop-in replacemant for CFFI and I don't
+want to export by hand all symbols exported by CFFI.
+|#
+
 (eval-when (:compile-toplevel :load-toplevel)
   (let ((p (find-package "CFFI-OBJECTS")))
     (when p
@@ -18,6 +26,21 @@
 (defpackage #:cffi-objects
   (:use #:common-lisp #:cffi)
   (:export
+   #:freeable-base
+   ;; slots
+   #:free-from-foreign
+   #:free-to-foreign
+   ;; freeable-base API
+   #:free-sent-if-needed
+   #:free-returned-if-needed
+   #:free-ptr
+   #:free-sent-ptr
+   #:free-returned-ptr
+
+   #:freeable
+   #:freeable-out
+   #:copy-from-foreign
+
    #:gconstructor
 
    #:object
@@ -55,15 +78,6 @@
    #:new-struct
    #:free-struct
 
-   #:freeable
-   #:freeable-base
-   #:free-sent-if-needed
-   #:free-returned-if-needed
-   #:free-ptr
-   #:freeable-out
-   #:copy-from-foreign
-   #:free-from-foreign
-   #:free-to-foreign
    
    #:defcstruct-accessors
    #:defcstruct*
@@ -80,8 +94,50 @@
    #:remove-setter
    #:clear-setters))
 
+;;;<doc> Now simply reexport all CFFI symbols.
 (eval-when (:compile-toplevel :load-toplevel)
   (let ((cffi (find-package "CFFI")) 
         (cffi-objects (find-package "CFFI-OBJECTS")))
     (do-external-symbols (v cffi)
-      (export (list v) cffi-objects))))
\ No newline at end of file
+      (export (list v) cffi-objects))))
+
+;;; <define name="introduction">
+#|<doc>
+[[* Introduction *]]
+
+This document describes CFFI-objects: library, that extends CFFI to support
+structures, objects and reference parameters.
+
+Other alternatives are Virgil and FSBV/cffi-libffi. Virgil tend to marshall all
+data back and forth. There are no support for structures as pointers.
+FSBV is obsoleted by cffi-libffi. Libffi I dislike, because it gives another
+layer of indirection (so make it slower) without new features (no bit fields
+in structures).
+
+So I made my own library. It gives the opportunity for programmer to
+say which structures should be return values and how to save every
+particular structure -- as pointer or as a lisp value.
+
+Example:
+\begin{alltt}
+ (defcstruct* foo (bar :int) (baz :int))
+ (defvar foo-as-ptr (make-instance 'foo :new-struct t))
+ (defvar foo-as-value (make-instance 'foo))
+
+ (defcfun foo-maker (struct foo))
+ (defcfun proceed-foo :void (param (struct foo :out t)))
+ (defcfun print-foo :void (param (struct foo)))
+\end{alltt}
+
+Here you can use either [[foo-as-ptr]] or [[foo-as-value]] in all functions.
+[[Foo-as-ptr]] is faster, because it shouldn't convert values from Lisp to C
+and back, but if foreign pointer is not considered stable (may be freed
+by another c-function) or you don't want to control, when you need
+to free foreign pointer, you should use [[foo-as-value]].
+
+\include{redefines}
+|#
+;;; </define>
+
+
+

Modified: redefines.lisp
==============================================================================
--- redefines.lisp	Sun Oct  7 04:59:54 2012	(r12)
+++ redefines.lisp	Sat Dec 22 11:24:45 2012	(r13)
@@ -1,17 +1,48 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
-;;;
-;;; redefines.lisp --- fix :double, alternate string
-;;;
-;;; Copyright (C) 2012, Roman Klochkov <monk at slavsoft.surgut.ru>
-;;;
+;;;;<author>Roman Klochkov, monk at slavsoft.surgut.ru</author>
+;;;; Several ad-hoc CFFI types for real numbers, keywords and pathnames
 
 (in-package #:cffi-objects)    
 
-(defmethod expand-to-foreign-dyn :around 
-    (value var body (type cffi::foreign-built-in-type))
-  (if (eq (cffi::type-keyword type) :double)
-      `(let ((,var (coerce ,value 'double-float))) , at body)
-      `(let ((,var ,value)) , at body)))
+;;;[ [[* Float numbers, keywords, pathnames *]]
+
+;;;[ <method expand-to-foreign-dyn>
+
+#|<doc>
+With plain CFFI language become slightly bondage. In lisp i have number,
+real and integer, but in CFFI only floats and ints. So, for example,
+this code is wrong
+\begin{alltt}
+ (defcfun sin :double (x :double))
+ (sin 0)
+should be
+ (sin 0.0d0)
+\end{alltt}
+
+I think, that this is unnnecessary. So here is my hack (it is hack, because
+it uses not exported symbols). It makes :double and :float to work, as if
+corresponding parameters coerced to the needed type.
+|#
+
+(defmethod expand-to-foreign-dyn (value var body 
+                                  (type cffi::foreign-built-in-type))
+  `(let ((,var 
+          ,(case (cffi::type-keyword type)
+                 (:double `(coerce ,value 'double-float))
+                 (:float `(coerce ,value 'single-float))
+                 (t value))
+           )) 
+     , at body))
+
+;;;[ <class cffi-keyword>
+
+#|<doc>
+Constant-like strings often used in C, particulary in GTK. 
+It is good to use lisp symbols in this case. 
+So [[cffi-keyword]] type use symbol name as a string for C parameter. 
+The name is downcased, because there are more string in downcase,
+than in upcase (for not downcased string you still may put string as is).
+Typical case for this type is using lisp keyword. So the name.
+|#
 
 (define-foreign-type cffi-keyword (freeable)
   ()
@@ -27,6 +58,13 @@
 (defmethod free-ptr ((type (eql 'cffi-keyword)) ptr)
   (foreign-string-free ptr))
 
+;;;[ <class cffi-pathname>
+
+#|<doc>
+The same case for pathnames. If C function expect path to file, 
+you may send it as a string or as a lisp pathname.
+|#
+
 (define-foreign-type cffi-pathname (freeable)
   ()
   (:simple-parser cffi-pathname)

Modified: struct.lisp
==============================================================================
--- struct.lisp	Sun Oct  7 04:59:54 2012	(r12)
+++ struct.lisp	Sat Dec 22 11:24:45 2012	(r13)
@@ -91,17 +91,19 @@
      (defcstruct-accessors ,class)
      (init-slots ,class)))
 
+(defun clos->struct (class object struct)
+  (let ((default (gensym)))
+    (mapc (lambda (slot) 
+            (let ((val (getf (slot-value object 'value) slot default)))
+              (unless (eq val default)
+                (setf (foreign-slot-value struct (list :struct class) slot) 
+                      val))))
+          (foreign-slot-names (list :struct class)))))
 
 (defun clos->new-struct (class object)
   (if (slot-boundp object 'value)
-      (let ((res (new-struct class))
-            (default (gensym)))
-        (mapc (lambda (slot) 
-                (let ((val (getf (slot-value object 'value) slot default)))
-                  (unless (eq val default)
-                    (setf (foreign-slot-value res (list :struct class) slot) 
-                          val))))
-              (foreign-slot-names class))
+      (let ((res (new-struct class)))
+        (clos->struct class object res)
         res)
       (pointer object)))
 
@@ -112,13 +114,13 @@
 Only exception is the presence of OBJECT with not boundp value"
   (let ((%object (or object
                      (unless (null-pointer-p struct)
-                       (make-instance class :pointer struct)))))
+                       (make-instance class)))))
     (when %object
       (if (slot-boundp %object 'value)
           (progn
             (setf (slot-value %object 'value) nil)
             (unless (null-pointer-p struct)
-              (dolist (slot (foreign-slot-names class))
+              (dolist (slot (foreign-slot-names (list :struct class)))
                 (setf (getf (slot-value %object 'value) slot) 
                       (foreign-slot-value struct (list :struct class) slot)))))
           (setf (pointer %object) struct))
@@ -139,7 +141,7 @@
 
 (defmethod foreign-type-size ((type cffi-struct))
   "Return the size in bytes of a foreign typedef."
-  (foreign-type-size (object-class type)))
+  (foreign-type-size (list :struct (object-class type))))
 
 (define-parse-method struct (class &rest rest)
   (apply #'make-instance 'cffi-struct :class class rest))
@@ -163,25 +165,31 @@
 
 
 ;; to allow using array of structs
-(eval-when (:compile-toplevel :load-toplevel :execute) 
-   (unless (get 'mem-ref 'struct)
-     (let ((old (fdefinition 'mem-ref)))
-       (fmakunbound 'mem-ref)
-       (defun mem-ref (ptr type &optional (offset 0))
-         (let ((ptype (cffi::parse-type type)))
-           (if (subtypep (type-of ptype) 'cffi-struct)
-               (translate-from-foreign (inc-pointer ptr offset) ptype)
-               (funcall old ptr type offset)))))
-     (setf (get 'mem-ref 'struct) t)))
+;; (eval-when (:compile-toplevel :load-toplevel :execute) 
+;;    (unless (get 'mem-ref 'struct)
+;;      (let ((old (fdefinition 'mem-ref)))
+;;        (fmakunbound 'mem-ref)
+;;        (defun mem-ref (ptr type &optional (offset 0))
+;;          (let ((ptype (cffi::parse-type type)))
+;;            (if (subtypep (type-of ptype) 'cffi-struct)
+;;                (translate-from-foreign (inc-pointer ptr offset) ptype)
+;;                (funcall old ptr type offset)))))
+;;      (setf (get 'mem-ref 'struct) t)))
 
+(defun struct-p (type)
+  (and (consp type) (eq (car type) 'struct)))
 
 (defun from-foreign (var type count)
   "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
   (if count
       (let ((res (make-array count)))
-        (dotimes (i count)
-          (setf (aref res i)
-                (mem-aref var type i)))
+        (if (struct-p type)
+            (dotimes (i count)
+              (setf (aref res i)
+                    (convert-from-foreign (mem-aptr var type i) type)))
+            (dotimes (i count)
+              (setf (aref res i)
+                    (mem-aref var type i))))
         res)
       (mem-ref var type)))
 



From rklochkov at common-lisp.net  Sun Dec 23 06:59:28 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Sat, 22 Dec 2012 22:59:28 -0800
Subject: [cffi-objects-cvs] r14 -
Message-ID: <E1TmfWy-0005QB-DT@common-lisp.net>

Author: rklochkov
Date: Sat Dec 22 22:59:28 2012
New Revision: 14

Log:
Added tests

Added:
   cffi-objects.tests.asd
   tests.lisp
Modified:
   cffi-objects.asd

Modified: cffi-objects.asd
==============================================================================
--- cffi-objects.asd	Sat Dec 22 11:24:45 2012	(r13)
+++ cffi-objects.asd	Sat Dec 22 22:59:28 2012	(r14)
@@ -24,11 +24,3 @@
    (:file setters :depends-on (package))
    (:file array :depends-on (struct))
    (:file struct :depends-on (object setters))))
-
-(defsystem cffi-objects.tests
-  :author "Roman Klochkov <monk at slavsoft.surgut.ru>"
-  :version "0.9"
-  :license "BSD"
-  :depends-on (cffi-objects hu.dwim.stefil)
-  :components
-  ((:file tests)))
\ No newline at end of file

Added: cffi-objects.tests.asd
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ cffi-objects.tests.asd	Sat Dec 22 22:59:28 2012	(r14)
@@ -0,0 +1,7 @@
+(defsystem cffi-objects.tests
+  :author "Roman Klochkov <monk at slavsoft.surgut.ru>"
+  :version "0.9"
+  :license "BSD"
+  :depends-on (cffi-objects hu.dwim.stefil)
+  :components
+  ((:file tests)))
\ No newline at end of file

Added: tests.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ tests.lisp	Sat Dec 22 22:59:28 2012	(r14)
@@ -0,0 +1,27 @@
+(defpackage #:cffi-objects.tests
+  (:use #:cl #:cffi-objects #:hu.dwim.stefil))
+
+(in-package #:cffi-objects.tests)
+
+(defsuite* (test-suite
+            :in root-suite
+            :documentation "Testing CFFI-objects"))
+
+(defcstruct* test
+  (x :int))
+
+(deftest test.carray ()
+  (is (= (let ((obj (make-instance 'test)))
+           (setf (x obj) 1)
+           (x obj)) 1))
+  (let ((obj (make-array 10)))
+    (dotimes (i 10)
+      (setf (aref obj i) 
+            (let ((struct (make-instance 'test)))
+              (setf (x struct) i)
+              struct)))
+    (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



From rklochkov at common-lisp.net  Tue Dec 25 01:10:43 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Mon, 24 Dec 2012 17:10:43 -0800
Subject: [cffi-objects-cvs] r15 -
Message-ID: <E1TnJ2Z-0001MR-6c@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)))))))



From rklochkov at common-lisp.net  Sat Dec 29 14:39:57 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Sat, 29 Dec 2012 06:39:57 -0800
Subject: [cffi-objects-cvs] r16 -
Message-ID: <E1ToxZt-00015K-Ao@common-lisp.net>

Author: rklochkov
Date: Sat Dec 29 06:39:56 2012
New Revision: 16

Log:
Added support of older CFFI versions (<= 10.7)

Modified:
   array.lisp
   struct.lisp

Modified: array.lisp
==============================================================================
--- array.lisp	Mon Dec 24 17:10:43 2012	(r15)
+++ array.lisp	Sat Dec 29 06:39:56 2012	(r16)
@@ -24,7 +24,8 @@
              (res (foreign-alloc type :count length)))
         (if (struct-p type)
             (dotimes (i length (values res t))
-              (clos->struct (second type) (elt value i) (mem-aptr res type i)))
+              (clos->struct (second type) (elt value i) 
+                            (ptr-struct res type i)))
             (dotimes (i length (values res t))
               (setf (mem-aref res type i) (elt value i)))))))
 
@@ -34,9 +35,8 @@
            (type (element-type cffi-array)))
       (if (struct-p type)
           (dotimes (i array-length res)
-            (setf (aref res i) (convert-from-foreign 
-                                (mem-aptr ptr (list :struct (second type)) i)
-                                type)))
+            (setf (aref res i) (convert-from-foreign (ptr-struct ptr type i)
+                                                     type)))
           (dotimes (i array-length res)
             (setf (aref res i) (mem-aref ptr type i)))))))
 

Modified: struct.lisp
==============================================================================
--- struct.lisp	Mon Dec 24 17:10:43 2012	(r15)
+++ struct.lisp	Sat Dec 29 06:39:56 2012	(r16)
@@ -25,6 +25,12 @@
     ;(format t "Free ~a ~a~%" class value)
     (foreign-free value)))
 
+(if (find-symbol "MEM-APTR" "CFFI") ;; new cffi
+    (defun struct-type (type)
+      (list :struct type))
+    (defun struct-type (type)
+      type))
+
 (defmethod gconstructor ((struct struct) &rest initargs 
                          &key new-struct &allow-other-keys)
   (let ((class-name (class-name (class-of struct)))
@@ -39,9 +45,9 @@
        (let ((val (getf initargs (alexandria:make-keyword field))))
          (if new-struct
              (setf (foreign-slot-value pointer 
-                                       (list :struct class-name) field) val)
+                                       (struct-type class-name) field) val)
              (setf (getf (slot-value struct 'value) field) val))))
-     (foreign-slot-names (list :struct class-name)))
+     (foreign-slot-names (struct-type class-name)))
     pointer))
 
 (defun pair (maybe-pair)
@@ -62,17 +68,17 @@
                 (if (slot-boundp ,class-name 'value)
                     (getf (slot-value ,class-name 'value) ',x)
                     (foreign-slot-value (pointer ,class-name)
-                                        '(:struct ,struct-name) ',x)))
+                                        ',(struct-type struct-name) ',x)))
               (unless (fboundp '(setf ,x))
                 (defgeneric (setf ,x) (val ,class-name)))
               (defmethod (setf ,x) (val (,class-name ,class-name))
                 (if (slot-boundp ,class-name 'value)
                     (setf (getf (slot-value ,class-name 'value) ',x) val)
                     (setf (foreign-slot-value (pointer ,class-name) 
-                                              '(:struct ,struct-name) ',x) 
+                                              ',(struct-type struct-name) ',x) 
                           val)))
               (save-setter ,class-name ,x)))
-          (foreign-slot-names `(:struct ,struct-name))))))
+          (foreign-slot-names (struct-type struct-name))))))
 
 (defmacro defbitaccessors (class slot &rest fields)
   (let ((pos 0))
@@ -107,9 +113,9 @@
     (mapc (lambda (slot) 
             (let ((val (getf (slot-value object 'value) slot default)))
               (unless (eq val default)
-                (setf (foreign-slot-value struct (list :struct class) slot) 
+                (setf (foreign-slot-value struct (struct-type class) slot) 
                       val))))
-          (foreign-slot-names (list :struct class)))))
+          (foreign-slot-names (struct-type class)))))
 
 (defun clos->new-struct (class object)
   (if (slot-boundp object 'value)
@@ -133,9 +139,9 @@
           (progn
             (setf (slot-value %object 'value) nil)
             (unless (null-pointer-p struct)
-              (dolist (slot (foreign-slot-names (list :struct class)))
+              (dolist (slot (foreign-slot-names (struct-type class)))
                 (setf (getf (slot-value %object 'value) slot) 
-                      (foreign-slot-value struct (list :struct class) slot)))))
+                      (foreign-slot-value struct (struct-type class) slot)))))
           (setf (pointer %object) struct))
       %object)))
 
@@ -154,7 +160,7 @@
 
 (defmethod foreign-type-size ((type cffi-struct))
   "Return the size in bytes of a foreign typedef."
-  (foreign-type-size (list :struct (object-class type))))
+  (foreign-type-size (struct-type (object-class type))))
 
 (define-parse-method struct (class &rest rest)
   (apply #'make-instance 'cffi-struct :class class rest))
@@ -192,6 +198,9 @@
 (defun struct-p (type)
   (and (consp type) (eq (car type) 'struct)))
 
+(defun ptr-struct (ptr type i)
+  (inc-pointer ptr (* i (foreign-type-size type))))
+
 (defun from-foreign (var type count)
   "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
   (if count
@@ -199,7 +208,7 @@
         (if (struct-p type)
             (dotimes (i count)
               (setf (aref res i)
-                    (convert-from-foreign (mem-aptr var type i) type)))
+                    (convert-from-foreign (ptr-struct var type i) type)))
             (dotimes (i count)
               (setf (aref res i)
                     (mem-aref var type i))))



From rklochkov at common-lisp.net  Mon Dec 31 13:35:32 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Mon, 31 Dec 2012 05:35:32 -0800
Subject: [cffi-objects-cvs] r17 -
Message-ID: <E1TpfWe-00088T-Lj@common-lisp.net>

Author: rklochkov
Date: Mon Dec 31 05:35:32 2012
New Revision: 17

Log:
Fixed memory leak. Added support of old (10.7) cffi

Modified:
   struct.lisp

Modified: struct.lisp
==============================================================================
--- struct.lisp	Sat Dec 29 06:39:56 2012	(r16)
+++ struct.lisp	Mon Dec 31 05:35:32 2012	(r17)
@@ -42,11 +42,12 @@
                 (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 
-                                       (struct-type class-name) field) val)
-             (setf (getf (slot-value struct 'value) field) val))))
+       (let ((val (getf initargs (alexandria:make-keyword field) :default)))
+         (unless (eq val :default)
+           (if new-struct
+               (setf (foreign-slot-value pointer 
+                                         (struct-type class-name) field) val)
+               (setf (getf (slot-value struct 'value) field) val)))))
      (foreign-slot-names (struct-type class-name)))
     pointer))
 
@@ -100,11 +101,19 @@
                  (incf pos size)))))
       (cons 'progn (mapcar #'build-field fields)))))
 
+(defun parse-struct (body)
+  (mapcar (lambda (str)
+            (if (stringp str) str
+                (let ((str2 (second str)))
+                  (if (and (consp str2) (eq (car str2) :struct))
+                      (list (first str) (struct-type (second str2)))
+                      str))))
+          body))
 
 (defmacro defcstruct* (class &body body)
   `(progn
      (defclass ,class (struct) ())
-     (defcstruct ,class , at body)
+     (defcstruct ,class ,@(parse-struct body))
      (defcstruct-accessors ,class)
      (init-slots ,class)))
 
@@ -121,7 +130,7 @@
   (if (slot-boundp object 'value)
       ;; use make-instance, not new-struct, because gconstructor
       ;;                                            may be redefined
-      (let ((res (make-instance class :new-struct t)))
+      (let ((res (make-instance class :new-struct t :free-after nil)))
         (clos->struct class object (pointer res))
         (pointer res))
       (pointer object)))