From rklochkov at common-lisp.net  Thu Feb  9 15:53:55 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Thu, 09 Feb 2012 07:53:55 -0800
Subject: [cffi-objects-cvs] r1 -
Message-ID: <E1RvWJn-0004lh-Sd@common-lisp.net>

Author: rklochkov
Date: Thu Feb  9 07:53:55 2012
New Revision: 1

Log:
Initial release

Added:
   cffi-objects.asd
   freeable.lisp
   object.lisp
   package.lisp
   pfunction.lisp
   redefines.lisp
   setters.lisp
   struct.lisp
   test.lisp

Added: cffi-objects.asd
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ cffi-objects.asd	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,25 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-object.asd --- ASDF system definition for cffi-objects
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(defpackage #:cffi-object-system
+  (:use #:cl #:asdf))
+(in-package #:cffi-object-system)
+
+(defsystem cffi-objects
+  :description "CFFI in-place replacement with object wrappers, structs and arrays"
+  :author "Roman Klochkov <monk at slavsoft.surgut.ru>"
+  :version "0.9"
+  :license "BSD"
+  :depends-on (cffi trivial-garbage)
+  :components
+  ((:file package)
+   (:file redefines :depends-on (package))
+   (:file freeable :depends-on (package))
+   (:file object :depends-on (freeable))
+   (:file pfunction :depends-on (package))
+   (:file setters :depends-on (package))
+   (:file struct :depends-on (object setters))))

Added: freeable.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ freeable.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,63 @@
+;;;; -*- Mode: lisp -*-
+;;;
+;;; freeable.lisp --- Interface for objects, that may be freed after use
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(in-package #:cffi-objects)
+
+(define-foreign-type freeable-base ()
+  ((free :accessor object-free :initarg :free :initform :no-transfer
+         :type (member :none :all :no-transfer :transfer)
+         :documentation "Free returned or sent value.
+:NONE -- no free at all
+:ALL -- 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.
+You should call FREE-RETURNED-IF-NEEDED and FREE-SENT-IF-NEEDED in
+appropriate places of your CFFI translators")))
+
+(defgeneric free-ptr (type ptr)
+  (:documentation "Called to free ptr, unless overriden free-sent-ptr or free-returned-ptr.")
+  (:method (type ptr)
+    (foreign-free ptr)))
+
+(defgeneric free-sent-ptr (type ptr)
+  (:method ((type freeable-base) ptr)
+    (free-ptr type ptr)))
+
+(defgeneric free-returned-ptr (type ptr)
+  (:method ((type freeable-base) ptr)
+    (free-ptr type ptr)))
+
+(defun free-sent-if-needed (type ptr)
+  (when (member (object-free type) '(:all :no-transfer))
+    (free-sent-ptr type ptr)))
+
+(defun free-returned-if-needed (type ptr)
+  (when (member (object-free type) '(:all :transfer))
+    (free-returned-ptr type ptr)))
+
+(defclass freeable (freeable-base) ()
+  (:documentation "Mixing to auto-set translators"))
+
+(defmethod free-translated-object :after (ptr (type freeable) param)
+  (declare (ignore param))
+  (free-sent-if-needed type ptr))
+
+(defmethod translate-from-foreign :after (ptr (type freeable))
+  (free-returned-if-needed type ptr))
+
+(define-foreign-type freeable-out (freeable)
+  ((out :accessor object-out :initarg :out :initform t
+        :documentation "This is out param (for fill in foreign side)"))
+  (:documentation "For returning data in out params.
+To use translate-to-foreign MUST return (values ptr place)"))
+
+(defgeneric copy-from-foreign (type ptr place)
+  (:documentation "Transfers data from pointer PTR to PLACE"))
+
+(defmethod free-translated-object :before (ptr (type freeable-out) place)
+  (when (object-out type)
+    (copy-from-foreign type ptr place)))

Added: object.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ object.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,128 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; object.lisp --- CFFI type OBJECT
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(in-package :cffi-objects)
+
+(defvar *objects* (make-hash-table)
+  "Hash table: foreign-pointer address as integer -> lisp object")
+
+(defvar *objects-ids* (make-hash-table)
+  "Hash table: atom -> lisp object")
+
+(defclass object ()
+  ((pointer :accessor pointer :initarg :pointer 
+            :initform (null-pointer) :type foreign-pointer)
+   ;; by default object shouldn't be stored unless it is GtkObject
+   (volatile :type boolean :accessor volatile 
+             :initarg :volatile :initform t
+             :documentation "Will not be saved in hash")
+   (free-after :type boolean :initarg :free-after :initform t
+               :documentation "Should be freed by finalizer")
+   (id :type symbol :accessor id :initarg :id :initform nil))
+  (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
+shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
+
+(defmethod (setf pointer) :after (value (object object))
+  (declare (type foreign-pointer value))
+  (tg:cancel-finalization object)
+  (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
+    (let ((class (class-of object)))
+      (tg:finalize object (lambda () 
+                            (free-ptr class value)))))
+                                        ; specialize EQL CLASS to override
+  (unless (or (volatile object) (null-pointer-p value))
+    (setf (gethash (pointer-address value) *objects*) object)
+    (when (id object)
+      (let ((cur-obj (gethash (id object) *objects-ids*)))
+        (unless (or (null cur-obj) (eq cur-obj object))
+          (warn "ID ~a for object ~a already set for ~a~%"
+                (id object) object (gethash (id object) *objects-ids*)))
+        (setf (gethash (id object) *objects-ids*) object)))))
+
+(defgeneric gconstructor (object &rest initargs)
+  (:documentation "Called during initialization of OBJECT instance.
+Should return a pointer to foreign OBJECT instance, 
+for example, by g_object_new."))
+
+(defmethod gconstructor (something-bad &rest rest)
+  (warn "No constructor for ~a ~a~%" something-bad rest))
+
+(defmethod shared-initialize :after ((object object) slot-names 
+                              &rest initargs
+                              &key pointer &allow-other-keys)
+  (unless pointer
+    (setf (pointer object) (apply #'gconstructor object initargs))))
+
+(defmethod pointer (something-bad)
+  (declare (ignore something-bad))
+  "Empty method to return null-pointer for non-objects"
+  (null-pointer))
+
+(defgeneric free (object)
+  (:documentation "Removes object pointer from lisp hashes."))
+
+(defmethod free ((object object))
+  (unless (null-pointer-p (pointer object))
+    (remhash (pointer-address (pointer object)) *objects*)
+    (remhash (id object) *objects-ids*)
+    (setf (pointer object) (null-pointer)
+          (id object) nil)))
+
+(defun find-object (pointer &optional class)
+  "Returns lisp object for an Object pointer.
+If not found or found with wrong class, create new one with given CLASS"
+  (declare (type symbol class) (type foreign-pointer pointer))
+  (unless (null-pointer-p pointer)
+    (let  ((try-find (gethash (pointer-address pointer) *objects*)))
+      (if class
+          (progn
+            (unless (or (null try-find)
+                        (eq (class-of try-find) (find-class class)))
+              (progn
+                (free try-find)
+                (setf try-find nil)))
+            (or try-find (make-instance class :pointer pointer)))
+        try-find))))
+
+(defun object-by-id (id-key)
+  (gethash id-key *objects-ids*))
+
+;; Type OBJECT
+;;   converts class object to pointer and vice versa
+
+(define-foreign-type cffi-object ()
+  ((class :initarg :class :accessor object-class))
+  (:actual-type :pointer))
+
+(define-parse-method object (&optional class)
+  (make-instance 'cffi-object :class class))
+
+(defmethod translate-to-foreign ((value null) (type cffi-object))
+  (null-pointer))
+
+(defmethod translate-to-foreign ((value object) (type cffi-object))
+  (pointer value))
+
+;; Hack: redefine translator for :pointer to be able to use
+;;       objects or nulls instead of pointer
+(defmethod translate-to-foreign ((value object)
+                                 (type cffi::foreign-pointer-type))
+  (pointer value))
+
+(defmethod translate-to-foreign ((value null)
+                                 (type cffi::foreign-pointer-type))
+  (null-pointer))
+
+(defmethod translate-to-foreign (value (type cffi-object))
+  (check-type value foreign-pointer)
+  value)
+
+(defmethod translate-from-foreign (ptr (cffi-object cffi-object))
+  (find-object ptr (object-class cffi-object)))
+
+
+

Added: package.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ package.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,69 @@
+;;;; -*- 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
+
+(in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (let ((p (find-package "CFFI-OBJECTS")))
+    (when p
+      (do-external-symbols (v p)
+        (unexport (list v) p)))))
+
+(defpackage #:cffi-objects
+  (:use #:common-lisp #:cffi)
+  (:export
+   #:gconstructor
+
+   #:object
+   #:object-by-id
+   #:*objects*
+   #:*objects-ids*
+   ;; slots
+   #:pointer
+   ;; methods
+   #:free
+
+   ;; types
+   #:pstring
+   #:pfunction
+   #:cffi-object
+
+   #:struct
+;   #:cffi-struct
+   #:new-struct
+   #:free-struct
+
+   #:freeable
+   #:freeable-base
+   #:free-sent-if-needed
+   #:free-returned-if-needed
+   #:free-ptr
+   #:freeable-out
+   #:copy-from-foreign
+   
+   #:defcstruct-accessors
+   #:defcstruct*
+   #:defbitaccessors
+
+   #:with-foreign-out
+   #:with-foreign-outs
+   #:with-foreign-outs-list
+
+   #:pair
+   #:setf-init
+   #:init-slots
+   #:save-setter
+   #:remove-setter
+   #:clear-setters))
+
+(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

Added: pfunction.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pfunction.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,25 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; object.lisp --- CFFI type PFUNCTION
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(in-package :cffi-objects)
+
+(define-foreign-type pfunction ()
+  ()
+  (:actual-type :pointer)
+  (:simple-parser pfunction)
+  (:documentation "Takes a foreign pointer, keyword or a string.
+Keyword or a string = name of C function, substituting #\- to #\_"))
+
+(defmethod translate-to-foreign (value (type pfunction))
+  (labels ((to-ptr (str)
+             (declare (type string str))
+             (foreign-symbol-pointer (substitute #\_ #\- str))))
+    (etypecase value
+      (string (to-ptr value))
+      (keyword (to-ptr (string-downcase value)))
+      (foreign-pointer value)
+      (null (null-pointer)))))

Added: redefines.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ redefines.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,30 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; redefines.lisp --- fix :double, alternate string
+;;;
+;;; Copyright (C) 2012, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(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)))
+
+;; make type string with :free for uniformity
+(define-foreign-type cffi-string (freeable)
+  ()
+  (:actual-type :pointer)
+  (:simple-parser pstring))
+
+(defmethod translate-to-foreign ((value string) (type cffi-string))
+  (values (foreign-string-alloc value) value))
+
+(defmethod free-ptr ((type cffi-string) ptr)
+  (foreign-string-free ptr))
+
+(defmethod translate-from-foreign (ptr (type cffi-string))
+  (foreign-string-to-lisp ptr))
+

Added: setters.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ setters.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,49 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; object.lisp --- Auto setters for foreign slots
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(in-package #:cffi-objects)
+
+(defmacro save-setter (class name)
+  "Use this to register setters for SETF-INIT and INIT-SLOTS macro"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+    (pushnew ',name (get ',class 'slots))))
+
+(defmacro remove-setter (class name)
+  "Use this to unregister setters for SETF-INIT and INIT-SLOTS macro"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+    (setf (get ',class 'slots)
+          (delete ',name (get ',class 'slots)))))
+
+(defmacro clear-setters (class)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+    (setf (get ',class 'slots) nil)))
+
+(defmacro setf-init (object &rest fields)
+  "Should be used in constructors"
+  `(progn
+     ,@(mapcar (lambda (field-all)
+                 (let ((field (if (consp field-all) 
+                                  (first field-all) field-all))
+                       (field-p (if (consp field-all)
+                                    (third field-all) field-all)))
+                   `(when ,field-p
+                      (setf (,field ,object) ,field))))
+               fields)))
+
+(defun name-p (name)
+  (intern (format nil "~a-P" name) (symbol-package name)))
+
+(defmacro init-slots (class &optional add-keys &body body)
+  "For SETF-INIT auto-constructor"
+  (let ((slots (mapcar (lambda (x) (list x nil (name-p x)))
+                       (get class 'slots))))
+    `(defmethod shared-initialize :after ((,class ,class) slot-names
+                                          &key , at slots , at add-keys
+                                          &allow-other-keys)
+       (declare (ignore slot-names))
+       (setf-init ,class , at slots)
+       , at body)))

Added: struct.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ struct.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,210 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; struct.lisp --- CFFI wrapper for structs. We need to save on lisp
+;;;                 side only values of struct field, not pointer on
+;;;                 the struct to be able to garbage collect it
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
+(in-package :cffi-objects)
+
+(defclass struct (object)
+  ((value :documentation "plist ({field-name field-value}*)"))
+  (:documentation "If value bound, use it, else use pointer.
+Struct may be used in OBJECT cffi-type or STRUCT cffi-type"))
+
+(defgeneric new-struct (class)
+  (:method (class)
+    (foreign-alloc class)))        
+
+(defgeneric free-struct (class value)
+  (:method (class value)
+    (declare (ignore class))
+    (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)
+        (null-pointer))))
+
+(defun pair (maybe-pair)
+  (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
+
+(defmacro defcstruct-accessors (class)
+  "CLASS may be symbol = class-name = struct name,
+or may be cons (class-name . struct-name)"
+  (destructuring-bind (class-name . struct-name) (pair class)
+    `(progn
+       (clear-setters ,class-name)
+       ,@(mapcar
+          (lambda (x) 
+           `(progn
+              (unless (fboundp ',x)
+                (defgeneric ,x (,class-name)))
+              (defmethod ,x ((,class-name ,class-name))
+                (if (slot-boundp ,class-name 'value)
+                    (getf (slot-value ,class-name 'value) ',x)
+                    (foreign-slot-value (pointer ,class-name)
+                                        ',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-name ',x) 
+                          val)))
+              (save-setter ,class-name ,x)))
+          (foreign-slot-names struct-name)))))
+
+(defmacro defbitaccessors (class slot &rest fields)
+  (let ((pos 0))
+    (flet ((build-field (field)
+             (destructuring-bind (name type size) field
+               (prog1 
+                   `(progn
+                      (unless (fboundp ',name)
+                        (defgeneric ,name (,class)))
+                      (defmethod ,name ((,class ,class))
+                        (convert-from-foreign 
+                         (ldb (byte ,size ,pos) (slot-value ,class ',slot))
+                         ,type))
+                      (unless (fboundp '(setf ,name))
+                        (defgeneric (setf ,name) (value ,class)))
+                      (defmethod (setf ,name) (value (,class ,class))
+                        (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
+                              (convert-to-foreign value ,type))))
+                 (incf pos size)))))
+      (cons 'progn (mapcar #'build-field fields)))))
+
+
+(defmacro defcstruct* (class &body body)
+  `(progn
+     (defclass ,class (struct) ())
+     (defcstruct ,class , at body)
+     (defcstruct-accessors ,class)
+     (init-slots ,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 class slot) val))))
+              (foreign-slot-names class))
+        res)
+      (slot-value object 'pointer)))
+
+(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))
+
+
+
+(define-foreign-type cffi-struct (cffi-object freeable-out)
+  ()
+  (:actual-type :pointer))
+
+(defmethod free-ptr ((type cffi-struct) ptr)
+  (free-struct (object-class type) ptr))
+
+(defmethod foreign-type-size ((type cffi-struct))
+  "Return the size in bytes of a foreign typedef."
+  (foreign-type-size (object-class type)))
+
+(define-parse-method struct (class &key (free :no-transfer) out)
+  (make-instance 'cffi-struct
+                 :class class :free free :out out))
+
+(defun %class (type value)
+  (or (object-class type) (class-name (class-of value))))
+
+(defmethod copy-from-foreign ((type cffi-object) ptr place)
+  (when (or (slot-boundp place 'value)
+            (member (object-free type) '(:all :transfer)))
+    (struct->clos (%class type place) ptr place)))
+
+(defmethod translate-to-foreign ((value struct) (type cffi-object))
+  (values (clos->new-struct (%class type value) value) value))
+
+(defmethod translate-from-foreign (value (type cffi-struct))
+  (struct->clos (object-class type) value))
+
+;;; Allowed use with object designator
+;; object == (struct nil :out t :free t)
+
+
+;; 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)))
+
+
+(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)))
+        res)
+      (mem-ref var type)))
+
+
+(defmacro with-foreign-out ((var type &optional count) return-result &body body)
+  "The same as WITH-FOREIGN-OBJECT, but returns value of object"
+  (let ((value `(from-foreign ,var ,type ,count)))
+  `(with-foreign-object (,var ,type ,@(when count (list count)))
+     ,(if (eq return-result :ignore)
+          `(progn , at body ,value)
+          `(let ((res , at body))
+             ,(ecase return-result
+                     (:if-success `(when res ,value))
+                     (:return `(values res ,value))))))))
+
+(flet 
+    ((make-with-foreign-outs (res-fun bindings return-result body)
+       (let ((values-form (mapcar (lambda (x)
+                                    (destructuring-bind 
+                                          (var type &optional count) x
+                                      `(from-foreign ,var ,type ,count)))
+                                  bindings)))
+         `(with-foreign-objects ,bindings
+            ,(if (eq return-result :ignore)
+                 `(progn , at body (,res-fun , at values-form))
+                 `(let ((res , at body))
+                    ,(ecase return-result
+                            (:if-success
+                             `(when res (,res-fun , at values-form)))
+                            (:return
+                              `(,res-fun res , at values-form)))))))))
+  
+  (defmacro with-foreign-outs (bindings return-result &body body)
+    "The same as WITH-FOREIGN-OBJECTS, but returns (values ...) 
+of result and binded vars, RETURN-RESULT may be 
+:RETURN - return result and values
+:IF-SUCCESS - return values if result t
+:IGNORE - discard result"
+    (make-with-foreign-outs 'values bindings return-result body))
+
+  (defmacro with-foreign-outs-list (bindings return-result &body body)
+    "The same as WITH-FOREIGN-OBJECTS, but returns list"
+    (make-with-foreign-outs 'list bindings return-result body)))

Added: test.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ test.lisp	Thu Feb  9 07:53:55 2012	(r1)
@@ -0,0 +1,30 @@
+(defpackage cffi-objects.test
+  (:use cl cffi-objects))
+(in-package cffi-objects.test)
+
+(defcallback test-double :double ((x :double))
+  (+ x 2))
+
+(defun call-test-double ()
+  (= 4 (foreign-funcall-pointer (callback test-double) () :double 2 :double)))
+
+(defcstruct* tstruct
+  (a :int)
+  (b :int))
+
+(defcallback test-struct :int ((x :pointer))
+  (setf (mem-aref x :int 0) 10)
+  (mem-aref x :int 1))
+
+(defun call-test-struct ()
+  (let ((s (make-instance 'tstruct)))
+    (setf (a s) 1 (b s) 2)
+    (prog1
+        (foreign-funcall-pointer 
+         (callback test-struct) () (struct tstruct :out t) s :int)
+      (assert (= (a s) 10)))))
+
+(assert (call-test-double))
+
+(assert (= (call-test-struct) 2))
+



From rklochkov at common-lisp.net  Mon Feb 20 18:55:21 2012
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Mon, 20 Feb 2012 10:55:21 -0800
Subject: [cffi-objects-cvs] r2 -
Message-ID: <E1RzYOP-0004o9-0a@common-lisp.net>

Author: rklochkov
Date: Mon Feb 20 10:55:20 2012
New Revision: 2

Log:
Added array with variable length

Added:
   array.lisp
Modified:
   cffi-objects.asd
   freeable.lisp
   package.lisp

Added: array.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ array.lisp	Mon Feb 20 10:55:20 2012	(r2)
@@ -0,0 +1,62 @@
+;;;
+;;; array.lisp --- array
+;;;
+;;; Copyright (C) 2012, Roman Klochkov <monk at slavsoft.surgut.ru>
+;;;
+
+(in-package #:cffi-objects)
+
+(defvar *array-length* (foreign-alloc :uint))
+
+;; TODO: add with-pointer-to-vector-data optimization
+(define-foreign-type cffi-array (freeable)
+  ((element-type :initarg :type :accessor element-type))
+  (:actual-type :pointer))
+
+(define-parse-method carray (type &key free)
+  (make-instance 'cffi-array :type type :free free))
+
+(defmethod translate-to-foreign (value (cffi-array cffi-array))
+  (if (pointerp value)
+      value
+      (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)))
+
+(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)))
+
+(define-foreign-type cffi-null-array (freeable)
+  ((element-type :initarg :type :accessor element-type))
+  (:actual-type :pointer))
+
+(define-parse-method null-array (type &key free)
+  (make-instance 'cffi-null-array :type type :free free))
+
+(defmethod translate-to-foreign (value (cffi-null-array cffi-null-array))
+  (if (pointerp value)
+      value
+      (let* ((length (length value))
+             (type (element-type cffi-null-array))
+             (res (foreign-alloc type :count (+ 1 length))))
+        (dotimes (i length (values res t))
+          (setf (mem-aref res type i) (elt value i)))
+        (setf (mem-aref res :pointer length) (null-pointer))
+        res)))
+
+(defmethod translate-from-foreign (ptr (cffi-null-array cffi-null-array))
+  (let* ((res nil)
+         (el-type (element-type cffi-null-array)))
+    (do ((i 0 (+ i 1))) ((null-pointer-p (mem-aref ptr :pointer i)))
+      (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

Modified: cffi-objects.asd
==============================================================================
--- cffi-objects.asd	Thu Feb  9 07:53:55 2012	(r1)
+++ cffi-objects.asd	Mon Feb 20 10:55:20 2012	(r2)
@@ -22,4 +22,5 @@
    (:file object :depends-on (freeable))
    (:file pfunction :depends-on (package))
    (:file setters :depends-on (package))
+   (:file array :depends-on (package))
    (:file struct :depends-on (object setters))))

Modified: freeable.lisp
==============================================================================
--- freeable.lisp	Thu Feb  9 07:53:55 2012	(r1)
+++ freeable.lisp	Mon Feb 20 10:55:20 2012	(r2)
@@ -9,12 +9,14 @@
 
 (define-foreign-type freeable-base ()
   ((free :accessor object-free :initarg :free :initform :no-transfer
-         :type (member :none :all :no-transfer :transfer)
+         :type (member :none :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)
 :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
+contained items
 You should call FREE-RETURNED-IF-NEEDED and FREE-SENT-IF-NEEDED in
 appropriate places of your CFFI translators")))
 
@@ -32,11 +34,11 @@
     (free-ptr type ptr)))
 
 (defun free-sent-if-needed (type ptr)
-  (when (member (object-free type) '(:all :no-transfer))
+  (when (member (object-free type) '(:all :container :no-transfer))
     (free-sent-ptr type ptr)))
 
 (defun free-returned-if-needed (type ptr)
-  (when (member (object-free type) '(:all :transfer))
+  (when (member (object-free type) '(:all :container :transfer))
     (free-returned-ptr type ptr)))
 
 (defclass freeable (freeable-base) ()

Modified: package.lisp
==============================================================================
--- package.lisp	Thu Feb  9 07:53:55 2012	(r1)
+++ package.lisp	Mon Feb 20 10:55:20 2012	(r2)
@@ -21,18 +21,28 @@
    #:gconstructor
 
    #:object
+   #:find-object
    #:object-by-id
    #:*objects*
    #:*objects-ids*
+   #:object-class
+   #:volatile
    ;; slots
    #:pointer
    ;; methods
    #:free
 
+
+   #:*array-length*
    ;; types
    #:pstring
    #:pfunction
    #:cffi-object
+   #:cffi-array
+   #:cffi-null-array
+   #:carray
+   #:null-array
+   #:string-array
 
    #:struct
 ;   #:cffi-struct