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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Mon Dec 31 13:35:32 2012 UTC (15 months, 2 weeks ago) by rklochkov
File size: 10510 byte(s)
Fixed memory leak. Added support of old (10.7) cffi
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; struct.lisp --- CFFI wrapper for structs. We need to save on lisp
4 ;;; side only values of struct field, not pointer on
5 ;;; the struct to be able to garbage collect it
6 ;;;
7 ;;; Copyright (C) 2011, Roman Klochkov <kalimehtar@mail.ru>
8 ;;;
9
10 (in-package :cffi-objects)
11
12 (defclass struct (object)
13 ((value :documentation "plist ({field-name field-value}*)"))
14 (:documentation "If value bound, use it, else use pointer.
15 Struct may be used in OBJECT cffi-type or STRUCT cffi-type"))
16
17 (defgeneric new-struct (class)
18 (:method (class)
19 (foreign-alloc class)))
20
21 (defgeneric free-struct (class value)
22 (:method (class value)
23 (declare (ignore class))
24 ; (break)
25 ;(format t "Free ~a ~a~%" class value)
26 (foreign-free value)))
27
28 (if (find-symbol "MEM-APTR" "CFFI") ;; new cffi
29 (defun struct-type (type)
30 (list :struct type))
31 (defun struct-type (type)
32 type))
33
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))
53
54 (defun pair (maybe-pair)
55 (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
56
57 (defmacro defcstruct-accessors (class)
58 "CLASS may be symbol = class-name = struct name,
59 or may be cons (class-name . struct-name)"
60 (destructuring-bind (class-name . struct-name) (pair class)
61 `(progn
62 (clear-setters ,class-name)
63 ,@(mapcar
64 (lambda (x)
65 `(progn
66 (unless (fboundp ',x)
67 (defgeneric ,x (,class-name)))
68 (defmethod ,x ((,class-name ,class-name))
69 (if (slot-boundp ,class-name 'value)
70 (getf (slot-value ,class-name 'value) ',x)
71 (foreign-slot-value (pointer ,class-name)
72 ',(struct-type struct-name) ',x)))
73 (unless (fboundp '(setf ,x))
74 (defgeneric (setf ,x) (val ,class-name)))
75 (defmethod (setf ,x) (val (,class-name ,class-name))
76 (if (slot-boundp ,class-name 'value)
77 (setf (getf (slot-value ,class-name 'value) ',x) val)
78 (setf (foreign-slot-value (pointer ,class-name)
79 ',(struct-type struct-name) ',x)
80 val)))
81 (save-setter ,class-name ,x)))
82 (foreign-slot-names (struct-type struct-name))))))
83
84 (defmacro defbitaccessors (class slot &rest fields)
85 (let ((pos 0))
86 (flet ((build-field (field)
87 (destructuring-bind (name type size) field
88 (prog1
89 `(progn
90 (unless (fboundp ',name)
91 (defgeneric ,name (,class)))
92 (defmethod ,name ((,class ,class))
93 (convert-from-foreign
94 (ldb (byte ,size ,pos) (slot-value ,class ',slot))
95 ,type))
96 (unless (fboundp '(setf ,name))
97 (defgeneric (setf ,name) (value ,class)))
98 (defmethod (setf ,name) (value (,class ,class))
99 (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
100 (convert-to-foreign value ,type))))
101 (incf pos size)))))
102 (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)
114 `(progn
115 (defclass ,class (struct) ())
116 (defcstruct ,class ,@(parse-struct body))
117 (defcstruct-accessors ,class)
118 (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)
130 (if (slot-boundp object 'value)
131 ;; use make-instance, not new-struct, because gconstructor
132 ;; may be redefined
133 (let ((res (make-instance class :new-struct t :free-after nil)))
134 (clos->struct class object (pointer res))
135 (pointer res))
136 (pointer object)))
137
138 (defun struct->clos (class struct &optional object)
139 "Translates pointer STRUCT to object OBJECT (if not supplied, then to new
140 object).
141 I suppose, that by default it should convert data from pointer to struct.
142 Only exception is the presence of OBJECT with not boundp value"
143 (let ((%object (or object
144 (unless (null-pointer-p struct)
145 (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)))
156
157 (define-foreign-type cffi-struct (cffi-object freeable-out)
158 ()
159 (:actual-type :pointer))
160
161 (defmethod free-sent-ptr ((type cffi-struct) ptr place)
162 (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
163 (free-struct (object-class type) ptr)))
164
165 (defmethod free-returned-ptr ((type cffi-struct) ptr)
166 (unless (null-pointer-p ptr)
167 (free-struct (object-class type) ptr)))
168
169
170 (defmethod foreign-type-size ((type cffi-struct))
171 "Return the size in bytes of a foreign typedef."
172 (foreign-type-size (struct-type (object-class type))))
173
174 (define-parse-method struct (class &rest rest)
175 (apply #'make-instance 'cffi-struct :class class rest))
176
177 (defun %class (type value)
178 (or (object-class type) (class-name (class-of value))))
179
180 (defmethod copy-from-foreign ((type cffi-object) ptr place)
181 (when (slot-boundp place 'value)
182 (struct->clos (%class type place) ptr place)))
183
184 ;; cffi-object is not tyoo. It is for use struct with object designator
185 (defmethod translate-to-foreign ((value struct) (type cffi-object))
186 (values (clos->new-struct (%class type value) value) value))
187
188 (defmethod translate-from-foreign (value (type cffi-struct))
189 (struct->clos (object-class type) value))
190
191 ;;; Allowed use with object designator
192 ;; object == (struct nil)
193
194
195 ;; to allow using array of structs
196 ;; (eval-when (:compile-toplevel :load-toplevel :execute)
197 ;; (unless (get 'mem-ref 'struct)
198 ;; (let ((old (fdefinition 'mem-ref)))
199 ;; (fmakunbound 'mem-ref)
200 ;; (defun mem-ref (ptr type &optional (offset 0))
201 ;; (let ((ptype (cffi::parse-type type)))
202 ;; (if (subtypep (type-of ptype) 'cffi-struct)
203 ;; (translate-from-foreign (inc-pointer ptr offset) ptype)
204 ;; (funcall old ptr type offset)))))
205 ;; (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)
214 "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
215 (if count
216 (let ((res (make-array count)))
217 (if (struct-p type)
218 (dotimes (i count)
219 (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)
225 (mem-ref var type)))
226
227
228 (defmacro with-foreign-out ((var type &optional count) return-result &body body)
229 "The same as WITH-FOREIGN-OBJECT, but returns value of object"
230 (let ((value `(from-foreign ,var ,type ,count)))
231 `(with-foreign-object (,var ,type ,@(when count (list count)))
232 ,(if (eq return-result :ignore)
233 `(progn ,@body ,value)
234 `(let ((res ,@body))
235 ,(ecase return-result
236 (:if-success `(when res ,value))
237 (:return `(values res ,value))))))))
238
239 (flet
240 ((make-with-foreign-outs (res-fun bindings return-result body)
241 (let ((values-form (mapcar (lambda (x)
242 (destructuring-bind
243 (var type &optional count) x
244 `(from-foreign ,var ,type ,count)))
245 bindings)))
246 `(with-foreign-objects ,bindings
247 ,(if (eq return-result :ignore)
248 `(progn ,@body (,res-fun ,@values-form))
249 `(let ((res ,@body))
250 ,(ecase return-result
251 (:if-success
252 `(when res (,res-fun ,@values-form)))
253 (:return
254 `(,res-fun res ,@values-form)))))))))
255
256 (defmacro with-foreign-outs (bindings return-result &body body)
257 "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
258 of result and binded vars, RETURN-RESULT may be
259 :RETURN - return result and values
260 :IF-SUCCESS - return values if result t
261 :IGNORE - discard result"
262 (make-with-foreign-outs 'values bindings return-result body))
263
264 (defmacro with-foreign-outs-list (bindings return-result &body body)
265 "The same as WITH-FOREIGN-OBJECTS, but returns list"
266 (make-with-foreign-outs 'list bindings return-result body)))

  ViewVC Help
Powered by ViewVC 1.1.5