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

Diff of /struct.lisp

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

revision 9 by rklochkov, Fri Aug 24 19:26:53 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
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) :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))
53    
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 51  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 ,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 ,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 ,struct-name))))))            (foreign-slot-names (struct-type struct-name))))))
83    
84  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
85    (let ((pos 0))    (let ((pos 0))
# Line 83  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)))))
103    
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))
112    
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)))
119    
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)))))
128    
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))
                     (setf (foreign-slot-value res class slot) val))))  
               (foreign-slot-names class))  
         res)  
136        (pointer object)))        (pointer object)))
137    
138  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
# Line 111  object). Line 142  object).
142  Only exception is the presence of OBJECT with not boundp value"  Only exception is the presence of OBJECT with not boundp value"
143    (let ((%object (or object    (let ((%object (or object
144                       (unless (null-pointer-p struct)                       (unless (null-pointer-p struct)
145                         (make-instance class :pointer struct)))))                         (make-instance class)))))
146      (when %object      (when %object
147        (if (slot-boundp %object 'value)        (if (slot-boundp %object 'value)
148            (progn            (progn
149              (setf (slot-value %object 'value) nil)              (setf (slot-value %object 'value) nil)
150              (unless (null-pointer-p struct)              (unless (null-pointer-p struct)
151                (dolist (slot (foreign-slot-names class))                (dolist (slot (foreign-slot-names (struct-type class)))
152                  (setf (getf (slot-value %object 'value) slot)                  (setf (getf (slot-value %object 'value) slot)
153                        (foreign-slot-value struct class slot)))))                        (foreign-slot-value struct (struct-type class) slot)))))
154            (setf (pointer %object) struct))            (setf (pointer %object) struct))
155        %object)))        %object)))
156    
# Line 128  Only exception is the presence of OBJECT Line 159  Only exception is the presence of OBJECT
159    (:actual-type :pointer))    (:actual-type :pointer))
160    
161  (defmethod free-sent-ptr ((type cffi-struct) ptr place)  (defmethod free-sent-ptr ((type cffi-struct) ptr place)
162    (when (and (slot-boundp place 'value) (not (null-pointer-p ptr)))    (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
163      (free-struct (object-class type) ptr)))      (free-struct (object-class type) ptr)))
164    
165  (defmethod free-returned-ptr ((type cffi-struct) ptr)  (defmethod free-returned-ptr ((type cffi-struct) ptr)
# Line 138  Only exception is the presence of OBJECT Line 169  Only exception is the presence of OBJECT
169    
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))))
173    
174  (define-parse-method struct (class &rest rest)  (define-parse-method struct (class &rest rest)
175    (apply #'make-instance 'cffi-struct :class class rest))    (apply #'make-instance 'cffi-struct :class class rest))
# Line 162  Only exception is the presence of OBJECT Line 193  Only exception is the presence of OBJECT
193    
194    
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)))
206    
207    (defun struct-p (type)
208      (and (consp type) (eq (car type) 'struct)))
209    
210    (defun ptr-struct (ptr type i)
211      (inc-pointer ptr (* i (foreign-type-size type))))
212    
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)))
226    

Legend:
Removed from v.9  
changed lines
  Added in v.17

  ViewVC Help
Powered by ViewVC 1.1.5