/[cffi-objects]/struct.lisp
ViewVC logotype

Diff of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1 by rklochkov, Thu Feb 9 15:53:55 2012 UTC revision 13 by rklochkov, Sat Dec 22 19:24:45 2012 UTC
# Line 21  Struct may be used in OBJECT cffi-type o Line 21  Struct may be used in OBJECT cffi-type o
21  (defgeneric free-struct (class value)  (defgeneric free-struct (class value)
22    (:method (class value)    (:method (class value)
23      (declare (ignore class))      (declare (ignore class))
24     ;   (break)
25        ;(format t "Free ~a ~a~%" class value)
26      (foreign-free value)))      (foreign-free value)))
27    
28  (defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys)  (defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys)
# Line 28  Struct may be used in OBJECT cffi-type o Line 30  Struct may be used in OBJECT cffi-type o
30        (new-struct (class-name (class-of struct)))        (new-struct (class-name (class-of struct)))
31        (progn        (progn
32          (setf (slot-value struct 'value) nil)          (setf (slot-value struct 'value) nil)
33            (setf (slot-value struct 'free-after) nil)
34          (null-pointer))))          (null-pointer))))
35    
36  (defun pair (maybe-pair)  (defun pair (maybe-pair)
# Line 48  or may be cons (class-name . struct-name Line 51  or may be cons (class-name . struct-name
51                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
52                      (getf (slot-value ,class-name 'value) ',x)                      (getf (slot-value ,class-name 'value) ',x)
53                      (foreign-slot-value (pointer ,class-name)                      (foreign-slot-value (pointer ,class-name)
54                                          ',struct-name ',x)))                                          '(:struct ,struct-name) ',x)))
55                (unless (fboundp '(setf ,x))                (unless (fboundp '(setf ,x))
56                  (defgeneric (setf ,x) (val ,class-name)))                  (defgeneric (setf ,x) (val ,class-name)))
57                (defmethod (setf ,x) (val (,class-name ,class-name))                (defmethod (setf ,x) (val (,class-name ,class-name))
58                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
59                      (setf (getf (slot-value ,class-name 'value) ',x) val)                      (setf (getf (slot-value ,class-name 'value) ',x) val)
60                      (setf (foreign-slot-value (pointer ,class-name)                      (setf (foreign-slot-value (pointer ,class-name)
61                                                ',struct-name ',x)                                                '(:struct ,struct-name) ',x)
62                            val)))                            val)))
63                (save-setter ,class-name ,x)))                (save-setter ,class-name ,x)))
64            (foreign-slot-names struct-name)))))            (foreign-slot-names `(:struct ,struct-name))))))
65    
66  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
67    (let ((pos 0))    (let ((pos 0))
# Line 88  or may be cons (class-name . struct-name Line 91  or may be cons (class-name . struct-name
91       (defcstruct-accessors ,class)       (defcstruct-accessors ,class)
92       (init-slots ,class)))       (init-slots ,class)))
93    
94    (defun clos->struct (class object struct)
95      (let ((default (gensym)))
96        (mapc (lambda (slot)
97                (let ((val (getf (slot-value object 'value) slot default)))
98                  (unless (eq val default)
99                    (setf (foreign-slot-value struct (list :struct class) slot)
100                          val))))
101              (foreign-slot-names (list :struct class)))))
102    
103  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
104    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
105        (let ((res (new-struct class))        (let ((res (new-struct class)))
106              (default (gensym)))          (clos->struct class object res)
         (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))  
107          res)          res)
108        (slot-value object 'pointer)))        (pointer object)))
109    
110  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
111    (let ((res (or object (make-instance class))))    "Translates pointer STRUCT to object OBJECT (if not supplied, then to new
112      (setf (slot-value res 'value) nil)  object).
113      (mapc (lambda (slot)    I suppose, that by default it should convert data from pointer to struct.
114              (setf (getf (slot-value res 'value) slot)  Only exception is the presence of OBJECT with not boundp value"
115                    (foreign-slot-value struct class slot)))    (let ((%object (or object
116            (foreign-slot-names class))                       (unless (null-pointer-p struct)
117      res))                         (make-instance class)))))
118        (when %object
119          (if (slot-boundp %object 'value)
120              (progn
121                (setf (slot-value %object 'value) nil)
122                (unless (null-pointer-p struct)
123                  (dolist (slot (foreign-slot-names (list :struct class)))
124                    (setf (getf (slot-value %object 'value) slot)
125                          (foreign-slot-value struct (list :struct class) slot)))))
126              (setf (pointer %object) struct))
127          %object)))
128    
129  (define-foreign-type cffi-struct (cffi-object freeable-out)  (define-foreign-type cffi-struct (cffi-object freeable-out)
130    ()    ()
131    (:actual-type :pointer))    (:actual-type :pointer))
132    
133  (defmethod free-ptr ((type cffi-struct) ptr)  (defmethod free-sent-ptr ((type cffi-struct) ptr place)
134    (free-struct (object-class type) ptr))    (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
135        (free-struct (object-class type) ptr)))
136    
137    (defmethod free-returned-ptr ((type cffi-struct) ptr)
138      (unless (null-pointer-p ptr)
139        (free-struct (object-class type) ptr)))
140    
141    
142  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
143    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
144    (foreign-type-size (object-class type)))    (foreign-type-size (list :struct (object-class type))))
145    
146  (define-parse-method struct (class &key (free :no-transfer) out)  (define-parse-method struct (class &rest rest)
147    (make-instance 'cffi-struct    (apply #'make-instance 'cffi-struct :class class rest))
                  :class class :free free :out out))  
148    
149  (defun %class (type value)  (defun %class (type value)
150    (or (object-class type) (class-name (class-of value))))    (or (object-class type) (class-name (class-of value))))
151    
152  (defmethod copy-from-foreign ((type cffi-object) ptr place)  (defmethod copy-from-foreign ((type cffi-object) ptr place)
153    (when (or (slot-boundp place 'value)    (when (slot-boundp place 'value)
             (member (object-free type) '(:all :transfer)))  
154      (struct->clos (%class type place) ptr place)))      (struct->clos (%class type place) ptr place)))
155    
156    ;; cffi-object is not tyoo. It is for use struct with object designator
157  (defmethod translate-to-foreign ((value struct) (type cffi-object))  (defmethod translate-to-foreign ((value struct) (type cffi-object))
158    (values (clos->new-struct (%class type value) value) value))    (values (clos->new-struct (%class type value) value) value))
159    
# Line 142  or may be cons (class-name . struct-name Line 161  or may be cons (class-name . struct-name
161    (struct->clos (object-class type) value))    (struct->clos (object-class type) value))
162    
163  ;;; Allowed use with object designator  ;;; Allowed use with object designator
164  ;; object == (struct nil :out t :free t)  ;; object == (struct nil)
165    
166    
167  ;; to allow using array of structs  ;; to allow using array of structs
168  (eval-when (:compile-toplevel :load-toplevel :execute)  ;; (eval-when (:compile-toplevel :load-toplevel :execute)
169     (unless (get 'mem-ref 'struct)  ;;    (unless (get 'mem-ref 'struct)
170       (let ((old (fdefinition 'mem-ref)))  ;;      (let ((old (fdefinition 'mem-ref)))
171         (fmakunbound 'mem-ref)  ;;        (fmakunbound 'mem-ref)
172         (defun mem-ref (ptr type &optional (offset 0))  ;;        (defun mem-ref (ptr type &optional (offset 0))
173           (let ((ptype (cffi::parse-type type)))  ;;          (let ((ptype (cffi::parse-type type)))
174             (if (subtypep (type-of ptype) 'cffi-struct)  ;;            (if (subtypep (type-of ptype) 'cffi-struct)
175                 (translate-from-foreign (inc-pointer ptr offset) ptype)  ;;                (translate-from-foreign (inc-pointer ptr offset) ptype)
176                 (funcall old ptr type offset)))))  ;;                (funcall old ptr type offset)))))
177       (setf (get 'mem-ref 'struct) t)))  ;;      (setf (get 'mem-ref 'struct) t)))
178    
179    (defun struct-p (type)
180      (and (consp type) (eq (car type) 'struct)))
181    
182  (defun from-foreign (var type count)  (defun from-foreign (var type count)
183    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
184    (if count    (if count
185        (let ((res (make-array count)))        (let ((res (make-array count)))
186          (dotimes (i count)          (if (struct-p type)
187            (setf (aref res i)              (dotimes (i count)
188                  (mem-aref var type i)))                (setf (aref res i)
189                        (convert-from-foreign (mem-aptr var type i) type)))
190                (dotimes (i count)
191                  (setf (aref res i)
192                        (mem-aref var type i))))
193          res)          res)
194        (mem-ref var type)))        (mem-ref var type)))
195    

Legend:
Removed from v.1  
changed lines
  Added in v.13

  ViewVC Help
Powered by ViewVC 1.1.5