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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 18 - (hide annotations)
Sat Jan 12 21:26:46 2013 UTC (15 months ago) by rklochkov
File size: 12131 byte(s)
Added support for MESSAGE-OO and (lisp-name . c-name) syntax for structure fields
1 rklochkov 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 rklochkov 15 (foreign-alloc class)))
20 rklochkov 1
21     (defgeneric free-struct (class value)
22     (:method (class value)
23     (declare (ignore class))
24 rklochkov 5 ; (break)
25 rklochkov 7 ;(format t "Free ~a ~a~%" class value)
26 rklochkov 1 (foreign-free value)))
27    
28 rklochkov 16 (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 rklochkov 15 (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 rklochkov 17 (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 rklochkov 16 (foreign-slot-names (struct-type class-name)))
52 rklochkov 15 pointer))
53 rklochkov 1
54     (defun pair (maybe-pair)
55     (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
56    
57 rklochkov 18 (defun slot-accessor (designator)
58     (flet ((count-args (list)
59     (do ((list list (cdr list))
60     (count 0 (1+ count)))
61     ((or (null list)
62     (char= (char (string (car list)) 0) #\&))
63     count))))
64     (let ((lambda-list
65     (closer-mop:generic-function-lambda-list (fdefinition designator))))
66     (= (count-args lambda-list) (if (listp designator) 2 1)))))
67    
68     (defmacro defaccessor (name c-name class &body body)
69     #-message-oo (declare (ignore c-name))
70     (let ((val* (when (listp name) (list 'val))))
71     `(progn
72     (unless (fboundp ',name)
73     (defgeneric ,name (,@val* ,class)))
74     (if (slot-accessor ',name)
75     (defmethod ,name (,@val* (,class ,class))
76     . ,body)
77     (warn 'style-warning
78     "~a is not a slot accessor" ',name))
79     #+message-oo
80     ,(if val*
81     `(defmessage ,class (,(alexandria:format-symbol
82     :keyword "~A=" c-name)
83     val)
84     . ,body)
85     `(defmessage ,class ,(alexandria:make-keyword c-name)
86     . ,body)))))
87    
88    
89     (defmacro defcstruct-accessors (class &rest fields)
90 rklochkov 1 "CLASS may be symbol = class-name = struct name,
91     or may be cons (class-name . struct-name)"
92     (destructuring-bind (class-name . struct-name) (pair class)
93     `(progn
94     (clear-setters ,class-name)
95     ,@(mapcar
96 rklochkov 18 (lambda (field)
97     (destructuring-bind (lisp-name . c-name) (pair field)
98     `(progn
99     (defaccessor ,lisp-name ,c-name ,class-name
100     (if (slot-boundp ,class-name 'value)
101     (getf (slot-value ,class-name 'value) ',c-name)
102     (foreign-slot-value (pointer ,class-name)
103     ',(struct-type struct-name)
104     ',c-name)))
105     (defaccessor (setf ,lisp-name) ,c-name ,class-name
106     (if (slot-boundp ,class-name 'value)
107     (setf (getf (slot-value ,class-name 'value)
108     ',c-name)
109     val)
110     (setf (foreign-slot-value
111     (pointer ,class-name)
112     ',(struct-type struct-name) ',c-name)
113 rklochkov 1 val)))
114 rklochkov 18 (save-setter ,class-name ,lisp-name))))
115     (or (mapcan (lambda (field)
116     (unless (stringp field) (list (car field))))
117     fields)
118     (foreign-slot-names (struct-type struct-name)))))))
119 rklochkov 1
120     (defmacro defbitaccessors (class slot &rest fields)
121     (let ((pos 0))
122     (flet ((build-field (field)
123     (destructuring-bind (name type size) field
124 rklochkov 18 (destructuring-bind (lisp-name . c-name) (pair name)
125     (prog1
126     `(progn
127     (defaccessor ,lisp-name ,c-name ,class
128     (convert-from-foreign
129     (ldb (byte ,size ,pos) (slot-value ,class ',slot))
130     ,type))
131     (defaccessor (setf ,lisp-name) ,c-name ,class
132     (setf (ldb (byte ,size ,pos)
133     (slot-value ,class ',slot))
134     (convert-to-foreign val ,type))))
135     (incf pos size))))))
136 rklochkov 1 (cons 'progn (mapcar #'build-field fields)))))
137    
138 rklochkov 17 (defun parse-struct (body)
139 rklochkov 18 (flet ((struct? (type)
140     (and (consp type) (eq (car type) :struct)))
141     (cname (name)
142     (destructuring-bind (lisp-name . c-name) (pair name)
143     (declare (ignore lisp-name))
144     c-name)))
145     (mapcar (lambda (str)
146     (if (stringp str) str
147     (list*
148     (cname (first str))
149     (let ((type (second str)))
150     (if (struct? type)
151     (struct-type (second type))
152     type))
153     (cddr str))))
154     body)))
155 rklochkov 1
156     (defmacro defcstruct* (class &body body)
157     `(progn
158     (defclass ,class (struct) ())
159 rklochkov 17 (defcstruct ,class ,@(parse-struct body))
160 rklochkov 1 (defcstruct-accessors ,class)
161     (init-slots ,class)))
162    
163 rklochkov 13 (defun clos->struct (class object struct)
164     (let ((default (gensym)))
165     (mapc (lambda (slot)
166     (let ((val (getf (slot-value object 'value) slot default)))
167     (unless (eq val default)
168 rklochkov 16 (setf (foreign-slot-value struct (struct-type class) slot)
169 rklochkov 13 val))))
170 rklochkov 16 (foreign-slot-names (struct-type class)))))
171 rklochkov 1
172     (defun clos->new-struct (class object)
173     (if (slot-boundp object 'value)
174 rklochkov 15 ;; use make-instance, not new-struct, because gconstructor
175     ;; may be redefined
176 rklochkov 17 (let ((res (make-instance class :new-struct t :free-after nil)))
177 rklochkov 15 (clos->struct class object (pointer res))
178     (pointer res))
179 rklochkov 4 (pointer object)))
180 rklochkov 1
181     (defun struct->clos (class struct &optional object)
182 rklochkov 5 "Translates pointer STRUCT to object OBJECT (if not supplied, then to new
183     object).
184     I suppose, that by default it should convert data from pointer to struct.
185     Only exception is the presence of OBJECT with not boundp value"
186     (let ((%object (or object
187     (unless (null-pointer-p struct)
188 rklochkov 13 (make-instance class)))))
189 rklochkov 5 (when %object
190     (if (slot-boundp %object 'value)
191     (progn
192     (setf (slot-value %object 'value) nil)
193     (unless (null-pointer-p struct)
194 rklochkov 16 (dolist (slot (foreign-slot-names (struct-type class)))
195 rklochkov 5 (setf (getf (slot-value %object 'value) slot)
196 rklochkov 16 (foreign-slot-value struct (struct-type class) slot)))))
197 rklochkov 5 (setf (pointer %object) struct))
198     %object)))
199 rklochkov 1
200     (define-foreign-type cffi-struct (cffi-object freeable-out)
201     ()
202     (:actual-type :pointer))
203    
204 rklochkov 5 (defmethod free-sent-ptr ((type cffi-struct) ptr place)
205 rklochkov 12 (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
206 rklochkov 5 (free-struct (object-class type) ptr)))
207    
208 rklochkov 9 (defmethod free-returned-ptr ((type cffi-struct) ptr)
209     (unless (null-pointer-p ptr)
210     (free-struct (object-class type) ptr)))
211 rklochkov 5
212 rklochkov 9
213 rklochkov 1 (defmethod foreign-type-size ((type cffi-struct))
214     "Return the size in bytes of a foreign typedef."
215 rklochkov 16 (foreign-type-size (struct-type (object-class type))))
216 rklochkov 1
217 rklochkov 8 (define-parse-method struct (class &rest rest)
218     (apply #'make-instance 'cffi-struct :class class rest))
219 rklochkov 1
220     (defun %class (type value)
221     (or (object-class type) (class-name (class-of value))))
222    
223     (defmethod copy-from-foreign ((type cffi-object) ptr place)
224 rklochkov 5 (when (slot-boundp place 'value)
225 rklochkov 1 (struct->clos (%class type place) ptr place)))
226    
227 rklochkov 5 ;; cffi-object is not tyoo. It is for use struct with object designator
228 rklochkov 1 (defmethod translate-to-foreign ((value struct) (type cffi-object))
229     (values (clos->new-struct (%class type value) value) value))
230    
231     (defmethod translate-from-foreign (value (type cffi-struct))
232     (struct->clos (object-class type) value))
233    
234     ;;; Allowed use with object designator
235 rklochkov 3 ;; object == (struct nil)
236 rklochkov 1
237    
238     ;; to allow using array of structs
239 rklochkov 13 ;; (eval-when (:compile-toplevel :load-toplevel :execute)
240     ;; (unless (get 'mem-ref 'struct)
241     ;; (let ((old (fdefinition 'mem-ref)))
242     ;; (fmakunbound 'mem-ref)
243     ;; (defun mem-ref (ptr type &optional (offset 0))
244     ;; (let ((ptype (cffi::parse-type type)))
245     ;; (if (subtypep (type-of ptype) 'cffi-struct)
246     ;; (translate-from-foreign (inc-pointer ptr offset) ptype)
247     ;; (funcall old ptr type offset)))))
248     ;; (setf (get 'mem-ref 'struct) t)))
249 rklochkov 1
250 rklochkov 13 (defun struct-p (type)
251     (and (consp type) (eq (car type) 'struct)))
252 rklochkov 1
253 rklochkov 16 (defun ptr-struct (ptr type i)
254     (inc-pointer ptr (* i (foreign-type-size type))))
255    
256 rklochkov 1 (defun from-foreign (var type count)
257     "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
258     (if count
259     (let ((res (make-array count)))
260 rklochkov 13 (if (struct-p type)
261     (dotimes (i count)
262     (setf (aref res i)
263 rklochkov 16 (convert-from-foreign (ptr-struct var type i) type)))
264 rklochkov 13 (dotimes (i count)
265     (setf (aref res i)
266     (mem-aref var type i))))
267 rklochkov 1 res)
268     (mem-ref var type)))
269    
270    
271     (defmacro with-foreign-out ((var type &optional count) return-result &body body)
272     "The same as WITH-FOREIGN-OBJECT, but returns value of object"
273     (let ((value `(from-foreign ,var ,type ,count)))
274     `(with-foreign-object (,var ,type ,@(when count (list count)))
275     ,(if (eq return-result :ignore)
276     `(progn ,@body ,value)
277     `(let ((res ,@body))
278     ,(ecase return-result
279     (:if-success `(when res ,value))
280     (:return `(values res ,value))))))))
281    
282     (flet
283     ((make-with-foreign-outs (res-fun bindings return-result body)
284     (let ((values-form (mapcar (lambda (x)
285     (destructuring-bind
286     (var type &optional count) x
287     `(from-foreign ,var ,type ,count)))
288     bindings)))
289     `(with-foreign-objects ,bindings
290     ,(if (eq return-result :ignore)
291     `(progn ,@body (,res-fun ,@values-form))
292     `(let ((res ,@body))
293     ,(ecase return-result
294     (:if-success
295     `(when res (,res-fun ,@values-form)))
296     (:return
297     `(,res-fun res ,@values-form)))))))))
298    
299     (defmacro with-foreign-outs (bindings return-result &body body)
300     "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
301     of result and binded vars, RETURN-RESULT may be
302     :RETURN - return result and values
303     :IF-SUCCESS - return values if result t
304     :IGNORE - discard result"
305     (make-with-foreign-outs 'values bindings return-result body))
306    
307     (defmacro with-foreign-outs-list (bindings return-result &body body)
308     "The same as WITH-FOREIGN-OBJECTS, but returns list"
309     (make-with-foreign-outs 'list bindings return-result body)))

  ViewVC Help
Powered by ViewVC 1.1.5