[gtk-cffi-cvs] CVS gtk-cffi/cffi

[CVS User rklochkov]

Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi
In directory tiger.common-lisp.net:/tmp/cvs-serv18018/cffi

Modified Files:
	package.lisp struct.lisp 
Log Message:
Fix struct in array processing


--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp	2011/09/16 17:58:33	1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp	2011/09/17 20:04:56	1.5
@@ -36,6 +36,7 @@
    
    #:defcstruct-accessors
    #:defcstruct*
+   #:defbitaccessors
 
    #:with-foreign-out
    #:with-foreign-outs
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp	2011/09/16 17:58:33	1.5
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp	2011/09/17 20:04:56	1.6
@@ -51,6 +51,7 @@
     `(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)))
 
@@ -66,7 +67,7 @@
           (lambda (x) 
            `(progn
               (unless (fboundp ',x)
-                (defgeneric ,x (class-name)))
+                (defgeneric ,x (,class-name)))
               (defmethod ,x ((,class-name ,class-name))
                 (if (slot-boundp ,class-name 'value)
                     (cdr (assoc ',x (slot-value ,class-name 'value)))
@@ -82,6 +83,27 @@
               (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
     (defcstruct ,class , at body)
@@ -137,10 +159,16 @@
         (struct->clos class value)
       (when (obj-free type) (free-struct class value)))))
 
-;; This is needed to get correct mem-aref, when used on array of structs 
-(defmethod cffi::aggregatep ((type cffi-struct))
-  "Returns true, structure types are aggregate."
-  t)
+;; This is needed to get correct mem-aref, when used on array of structs
+(eval-when (:compile-toplevel :load-toplevel :execute) 
+  (unless (get 'mem-ref 'struct)
+    (let ((old (fdefinition '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"