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 17 by rklochkov, Mon Dec 31 13:35:32 2012 UTC
# Line 16  Struct may be used in OBJECT cffi-type o Line 16  Struct may be used in OBJECT cffi-type o
17  (defgeneric new-struct (class)  (defgeneric new-struct (class)
18    (:method (class)    (:method (class)
19      (foreign-alloc class)))      (foreign-alloc class)))
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)))
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          (null-pointer))))  
34    (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) :default)))
46             (unless (eq val :default)
47               (if new-struct
48                   (setf (foreign-slot-value pointer
49                                             (struct-type class-name) field) val)
50                   (setf (getf (slot-value struct 'value) field) val)))))
51         (foreign-slot-names (struct-type class-name)))
52        pointer))
54  (defun pair (maybe-pair)  (defun pair (maybe-pair)
55    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
# Line 48  or may be cons (class-name . struct-name Line 69  or may be cons (class-name . struct-name
69                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
70                      (getf (slot-value ,class-name 'value) ',x)                      (getf (slot-value ,class-name 'value) ',x)
71                      (foreign-slot-value (pointer ,class-name)                      (foreign-slot-value (pointer ,class-name)
72                                          ',struct-name ',x)))                                          ',(struct-type struct-name) ',x)))
73                (unless (fboundp '(setf ,x))                (unless (fboundp '(setf ,x))
74                  (defgeneric (setf ,x) (val ,class-name)))                  (defgeneric (setf ,x) (val ,class-name)))
75                (defmethod (setf ,x) (val (,class-name ,class-name))                (defmethod (setf ,x) (val (,class-name ,class-name))
76                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
77                      (setf (getf (slot-value ,class-name 'value) ',x) val)                      (setf (getf (slot-value ,class-name 'value) ',x) val)
78                      (setf (foreign-slot-value (pointer ,class-name)                      (setf (foreign-slot-value (pointer ,class-name)
79                                                ',struct-name ',x)                                                ',(struct-type struct-name) ',x)
80                            val)))                            val)))
81                (save-setter ,class-name ,x)))                (save-setter ,class-name ,x)))
82            (foreign-slot-names struct-name)))))            (foreign-slot-names (struct-type struct-name))))))
84  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
85    (let ((pos 0))    (let ((pos 0))
# Line 80  or may be cons (class-name . struct-name Line 101  or may be cons (class-name . struct-name
101                   (incf pos size)))))                   (incf pos size)))))
102        (cons 'progn (mapcar #'build-field fields)))))        (cons 'progn (mapcar #'build-field fields)))))
104    (defun parse-struct (body)
105      (mapcar (lambda (str)
106                (if (stringp str) str
107                    (let ((str2 (second str)))
108                      (if (and (consp str2) (eq (car str2) :struct))
109                          (list (first str) (struct-type (second str2)))
110                          str))))
111              body))
113  (defmacro defcstruct* (class &body body)  (defmacro defcstruct* (class &body body)
114    `(progn    `(progn
115       (defclass ,class (struct) ())       (defclass ,class (struct) ())
116       (defcstruct ,class ,@body)       (defcstruct ,class ,@(parse-struct body))
117       (defcstruct-accessors ,class)       (defcstruct-accessors ,class)
118       (init-slots ,class)))       (init-slots ,class)))
120    (defun clos->struct (class object struct)
121      (let ((default (gensym)))
122        (mapc (lambda (slot)
123                (let ((val (getf (slot-value object 'value) slot default)))
124                  (unless (eq val default)
125                    (setf (foreign-slot-value struct (struct-type class) slot)
126                          val))))
127              (foreign-slot-names (struct-type class)))))
129  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
130    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
131        (let ((res (new-struct class))        ;; use make-instance, not new-struct, because gconstructor
132              (default (gensym)))        ;;                                            may be redefined
133          (mapc (lambda (slot)        (let ((res (make-instance class :new-struct t :free-after nil)))
134                  (let ((val (getf (slot-value object 'value) slot default)))          (clos->struct class object (pointer res))
135                    (unless (eq val default)          (pointer res))
136                      (setf (foreign-slot-value res class slot) val))))        (pointer object)))
               (foreign-slot-names class))  
       (slot-value object 'pointer)))  
138  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
139    (let ((res (or object (make-instance class))))    "Translates pointer STRUCT to object OBJECT (if not supplied, then to new
140      (setf (slot-value res 'value) nil)  object).
141      (mapc (lambda (slot)    I suppose, that by default it should convert data from pointer to struct.
142              (setf (getf (slot-value res 'value) slot)  Only exception is the presence of OBJECT with not boundp value"
143                    (foreign-slot-value struct class slot)))    (let ((%object (or object
144            (foreign-slot-names class))                       (unless (null-pointer-p struct)
145      res))                         (make-instance class)))))
146        (when %object
147          (if (slot-boundp %object 'value)
148              (progn
149                (setf (slot-value %object 'value) nil)
150                (unless (null-pointer-p struct)
151                  (dolist (slot (foreign-slot-names (struct-type class)))
152                    (setf (getf (slot-value %object 'value) slot)
153                          (foreign-slot-value struct (struct-type class) slot)))))
154              (setf (pointer %object) struct))
155          %object)))
157  (define-foreign-type cffi-struct (cffi-object freeable-out)  (define-foreign-type cffi-struct (cffi-object freeable-out)
158    ()    ()
159    (:actual-type :pointer))    (:actual-type :pointer))
161  (defmethod free-ptr ((type cffi-struct) ptr)  (defmethod free-sent-ptr ((type cffi-struct) ptr place)
162    (free-struct (object-class type) ptr))    (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
163        (free-struct (object-class type) ptr)))
165    (defmethod free-returned-ptr ((type cffi-struct) ptr)
166      (unless (null-pointer-p ptr)
167        (free-struct (object-class type) ptr)))
170  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
171    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
172    (foreign-type-size (object-class type)))    (foreign-type-size (struct-type (object-class type))))
174  (define-parse-method struct (class &key (free :no-transfer) out)  (define-parse-method struct (class &rest rest)
175    (make-instance 'cffi-struct    (apply #'make-instance 'cffi-struct :class class rest))
                  :class class :free free :out out))  
177  (defun %class (type value)  (defun %class (type value)
178    (or (object-class type) (class-name (class-of value))))    (or (object-class type) (class-name (class-of value))))
180  (defmethod copy-from-foreign ((type cffi-object) ptr place)  (defmethod copy-from-foreign ((type cffi-object) ptr place)
181    (when (or (slot-boundp place 'value)    (when (slot-boundp place 'value)
             (member (object-free type) '(:all :transfer)))  
182      (struct->clos (%class type place) ptr place)))      (struct->clos (%class type place) ptr place)))
184    ;; cffi-object is not tyoo. It is for use struct with object designator
185  (defmethod translate-to-foreign ((value struct) (type cffi-object))  (defmethod translate-to-foreign ((value struct) (type cffi-object))
186    (values (clos->new-struct (%class type value) value) value))    (values (clos->new-struct (%class type value) value) value))
# Line 142  or may be cons (class-name . struct-name Line 189  or may be cons (class-name . struct-name
189    (struct->clos (object-class type) value))    (struct->clos (object-class type) value))
191  ;;; Allowed use with object designator  ;;; Allowed use with object designator
192  ;; object == (struct nil :out t :free t)  ;; object == (struct nil)
195  ;; to allow using array of structs  ;; to allow using array of structs
196  (eval-when (:compile-toplevel :load-toplevel :execute)  ;; (eval-when (:compile-toplevel :load-toplevel :execute)
197     (unless (get 'mem-ref 'struct)  ;;    (unless (get 'mem-ref 'struct)
198       (let ((old (fdefinition 'mem-ref)))  ;;      (let ((old (fdefinition 'mem-ref)))
199         (fmakunbound 'mem-ref)  ;;        (fmakunbound 'mem-ref)
200         (defun mem-ref (ptr type &optional (offset 0))  ;;        (defun mem-ref (ptr type &optional (offset 0))
201           (let ((ptype (cffi::parse-type type)))  ;;          (let ((ptype (cffi::parse-type type)))
202             (if (subtypep (type-of ptype) 'cffi-struct)  ;;            (if (subtypep (type-of ptype) 'cffi-struct)
203                 (translate-from-foreign (inc-pointer ptr offset) ptype)  ;;                (translate-from-foreign (inc-pointer ptr offset) ptype)
204                 (funcall old ptr type offset)))))  ;;                (funcall old ptr type offset)))))
205       (setf (get 'mem-ref 'struct) t)))  ;;      (setf (get 'mem-ref 'struct) t)))
207    (defun struct-p (type)
208      (and (consp type) (eq (car type) 'struct)))
210    (defun ptr-struct (ptr type i)
211      (inc-pointer ptr (* i (foreign-type-size type))))
213  (defun from-foreign (var type count)  (defun from-foreign (var type count)
214    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
215    (if count    (if count
216        (let ((res (make-array count)))        (let ((res (make-array count)))
217          (dotimes (i count)          (if (struct-p type)
218            (setf (aref res i)              (dotimes (i count)
219                  (mem-aref var type i)))                (setf (aref res i)
220                        (convert-from-foreign (ptr-struct var type i) type)))
221                (dotimes (i count)
222                  (setf (aref res i)
223                        (mem-aref var type i))))
224          res)          res)
225        (mem-ref var type)))        (mem-ref var type)))

Removed from v.1  
changed lines
  Added in v.17

  ViewVC Help
Powered by ViewVC 1.1.5