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

Diff of /struct.lisp

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

revision 12 by rklochkov, Sun Oct 7 11:59:54 2012 UTC revision 16 by rklochkov, Sat Dec 29 14:39:56 2012 UTC
# Line 16  Struct may be used in OBJECT cffi-type o Line 16  Struct may be used in OBJECT cffi-type o
16    
17  (defgeneric new-struct (class)  (defgeneric new-struct (class)
18    (:method (class)    (:method (class)
19      (foreign-alloc class)))      (foreign-alloc class)))
20    
21  (defgeneric free-struct (class value)  (defgeneric free-struct (class value)
22    (:method (class value)    (:method (class value)
# Line 25  Struct may be used in OBJECT cffi-type o Line 25  Struct may be used in OBJECT cffi-type o
25      ;(format t "Free ~a ~a~%" class value)      ;(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)  (if (find-symbol "MEM-APTR" "CFFI") ;; new cffi
29    (if new-struct      (defun struct-type (type)
30        (new-struct (class-name (class-of struct)))        (list :struct type))
31        (progn      (defun struct-type (type)
32          (setf (slot-value struct 'value) nil)        type))
33          (setf (slot-value struct 'free-after) nil)  
34          (null-pointer))))  (defmethod gconstructor ((struct struct) &rest initargs
35                             &key new-struct &allow-other-keys)
36      (let ((class-name (class-name (class-of struct)))
37            (pointer (null-pointer)))
38        (if new-struct
39            (setf pointer (new-struct class-name))
40            (progn
41              (setf (slot-value struct 'value) nil
42                    (slot-value struct 'free-after) nil)))
43        (mapc
44         (lambda (field)
45           (let ((val (getf initargs (alexandria:make-keyword field))))
46             (if new-struct
47                 (setf (foreign-slot-value pointer
48                                           (struct-type class-name) field) val)
49                 (setf (getf (slot-value struct 'value) field) val))))
50         (foreign-slot-names (struct-type class-name)))
51        pointer))
52    
53  (defun pair (maybe-pair)  (defun pair (maybe-pair)
54    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
# Line 51  or may be cons (class-name . struct-name Line 68  or may be cons (class-name . struct-name
68                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
69                      (getf (slot-value ,class-name 'value) ',x)                      (getf (slot-value ,class-name 'value) ',x)
70                      (foreign-slot-value (pointer ,class-name)                      (foreign-slot-value (pointer ,class-name)
71                                          '(:struct ,struct-name) ',x)))                                          ',(struct-type struct-name) ',x)))
72                (unless (fboundp '(setf ,x))                (unless (fboundp '(setf ,x))
73                  (defgeneric (setf ,x) (val ,class-name)))                  (defgeneric (setf ,x) (val ,class-name)))
74                (defmethod (setf ,x) (val (,class-name ,class-name))                (defmethod (setf ,x) (val (,class-name ,class-name))
75                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
76                      (setf (getf (slot-value ,class-name 'value) ',x) val)                      (setf (getf (slot-value ,class-name 'value) ',x) val)
77                      (setf (foreign-slot-value (pointer ,class-name)                      (setf (foreign-slot-value (pointer ,class-name)
78                                                '(:struct ,struct-name) ',x)                                                ',(struct-type struct-name) ',x)
79                            val)))                            val)))
80                (save-setter ,class-name ,x)))                (save-setter ,class-name ,x)))
81            (foreign-slot-names `(:struct ,struct-name))))))            (foreign-slot-names (struct-type struct-name))))))
82    
83  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
84    (let ((pos 0))    (let ((pos 0))
# Line 91  or may be cons (class-name . struct-name Line 108  or may be cons (class-name . struct-name
108       (defcstruct-accessors ,class)       (defcstruct-accessors ,class)
109       (init-slots ,class)))       (init-slots ,class)))
110    
111    (defun clos->struct (class object struct)
112      (let ((default (gensym)))
113        (mapc (lambda (slot)
114                (let ((val (getf (slot-value object 'value) slot default)))
115                  (unless (eq val default)
116                    (setf (foreign-slot-value struct (struct-type class) slot)
117                          val))))
118              (foreign-slot-names (struct-type class)))))
119    
120  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
121    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
122        (let ((res (new-struct class))        ;; use make-instance, not new-struct, because gconstructor
123              (default (gensym)))        ;;                                            may be redefined
124          (mapc (lambda (slot)        (let ((res (make-instance class :new-struct t)))
125                  (let ((val (getf (slot-value object 'value) slot default)))          (clos->struct class object (pointer res))
126                    (unless (eq val default)          (pointer res))
                     (setf (foreign-slot-value res (list :struct class) slot)  
                           val))))  
               (foreign-slot-names class))  
         res)  
127        (pointer object)))        (pointer object)))
128    
129  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
# Line 112  object). Line 133  object).
133  Only exception is the presence of OBJECT with not boundp value"  Only exception is the presence of OBJECT with not boundp value"
134    (let ((%object (or object    (let ((%object (or object
135                       (unless (null-pointer-p struct)                       (unless (null-pointer-p struct)
136                         (make-instance class :pointer struct)))))                         (make-instance class)))))
137      (when %object      (when %object
138        (if (slot-boundp %object 'value)        (if (slot-boundp %object 'value)
139            (progn            (progn
140              (setf (slot-value %object 'value) nil)              (setf (slot-value %object 'value) nil)
141              (unless (null-pointer-p struct)              (unless (null-pointer-p struct)
142                (dolist (slot (foreign-slot-names class))                (dolist (slot (foreign-slot-names (struct-type class)))
143                  (setf (getf (slot-value %object 'value) slot)                  (setf (getf (slot-value %object 'value) slot)
144                        (foreign-slot-value struct (list :struct class) slot)))))                        (foreign-slot-value struct (struct-type class) slot)))))
145            (setf (pointer %object) struct))            (setf (pointer %object) struct))
146        %object)))        %object)))
147    
# Line 139  Only exception is the presence of OBJECT Line 160  Only exception is the presence of OBJECT
160    
161  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
162    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
163    (foreign-type-size (object-class type)))    (foreign-type-size (struct-type (object-class type))))
164    
165  (define-parse-method struct (class &rest rest)  (define-parse-method struct (class &rest rest)
166    (apply #'make-instance 'cffi-struct :class class rest))    (apply #'make-instance 'cffi-struct :class class rest))
# Line 163  Only exception is the presence of OBJECT Line 184  Only exception is the presence of OBJECT
184    
185    
186  ;; to allow using array of structs  ;; to allow using array of structs
187  (eval-when (:compile-toplevel :load-toplevel :execute)  ;; (eval-when (:compile-toplevel :load-toplevel :execute)
188     (unless (get 'mem-ref 'struct)  ;;    (unless (get 'mem-ref 'struct)
189       (let ((old (fdefinition 'mem-ref)))  ;;      (let ((old (fdefinition 'mem-ref)))
190         (fmakunbound 'mem-ref)  ;;        (fmakunbound 'mem-ref)
191         (defun mem-ref (ptr type &optional (offset 0))  ;;        (defun mem-ref (ptr type &optional (offset 0))
192           (let ((ptype (cffi::parse-type type)))  ;;          (let ((ptype (cffi::parse-type type)))
193             (if (subtypep (type-of ptype) 'cffi-struct)  ;;            (if (subtypep (type-of ptype) 'cffi-struct)
194                 (translate-from-foreign (inc-pointer ptr offset) ptype)  ;;                (translate-from-foreign (inc-pointer ptr offset) ptype)
195                 (funcall old ptr type offset)))))  ;;                (funcall old ptr type offset)))))
196       (setf (get 'mem-ref 'struct) t)))  ;;      (setf (get 'mem-ref 'struct) t)))
197    
198    (defun struct-p (type)
199      (and (consp type) (eq (car type) 'struct)))
200    
201    (defun ptr-struct (ptr type i)
202      (inc-pointer ptr (* i (foreign-type-size type))))
203    
204  (defun from-foreign (var type count)  (defun from-foreign (var type count)
205    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
206    (if count    (if count
207        (let ((res (make-array count)))        (let ((res (make-array count)))
208          (dotimes (i count)          (if (struct-p type)
209            (setf (aref res i)              (dotimes (i count)
210                  (mem-aref var type i)))                (setf (aref res i)
211                        (convert-from-foreign (ptr-struct var type i) type)))
212                (dotimes (i count)
213                  (setf (aref res i)
214                        (mem-aref var type i))))
215          res)          res)
216        (mem-ref var type)))        (mem-ref var type)))
217    

Legend:
Removed from v.12  
changed lines
  Added in v.16

  ViewVC Help
Powered by ViewVC 1.1.5