[cffi-objects-cvs] r2 -

[rklochkov at 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