[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
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)))
More information about the cffi-objects-cvs
mailing list