[cffi-objects-cvs] r13 -

rklochkov at common-lisp.net rklochkov at common-lisp.net
Sat Dec 22 19:24:45 UTC 2012

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

Fixed array. Removed redefinition of cffi:mem-ref


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 *]]
+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 
+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: 
+\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)))
-;; appropriate places of your CFFI translators")))
+   (free-to-foreign :initarg :free-to-foreign
+                    :reader fst-free-to-foreign-p
+                    :initform t :type boolean)))
+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)>
+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
+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>
+;;;; 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)
+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)
+   #: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
@@ -55,15 +78,6 @@
-   #:freeable
-   #:freeable-base
-   #:free-sent-if-needed
-   #:free-returned-if-needed
-   #:free-ptr
-   #:freeable-out
-   #:copy-from-foreign
-   #:free-from-foreign
-   #:free-to-foreign
@@ -80,8 +94,50 @@
+;;;<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">
+[[* 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.
+ (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)))
+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]].
+;;; </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>
+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
+ (defcfun sin :double (x :double))
+ (sin 0)
+should be
+ (sin 0.0d0)
+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>
+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>
+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)
       (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)
             (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))))
       (mem-ref var type)))

More information about the cffi-objects-cvs mailing list