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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (hide annotations)
Sat Dec 29 14:39:56 2012 UTC (15 months, 2 weeks ago) by rklochkov
File size: 10117 byte(s)
Added support of older CFFI versions (<= 10.7)
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     (let ((val (getf initargs (alexandria:make-keyword field))))
46     (if new-struct
47     (setf (foreign-slot-value pointer
48 rklochkov 16 (struct-type class-name) field) val)
49 rklochkov 15 (setf (getf (slot-value struct 'value) field) val))))
50 rklochkov 16 (foreign-slot-names (struct-type class-name)))
51 rklochkov 15 pointer))
52 rklochkov 1
53     (defun pair (maybe-pair)
54     (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
55    
56     (defmacro defcstruct-accessors (class)
57     "CLASS may be symbol = class-name = struct name,
58     or may be cons (class-name . struct-name)"
59     (destructuring-bind (class-name . struct-name) (pair class)
60     `(progn
61     (clear-setters ,class-name)
62     ,@(mapcar
63     (lambda (x)
64     `(progn
65     (unless (fboundp ',x)
66     (defgeneric ,x (,class-name)))
67     (defmethod ,x ((,class-name ,class-name))
68     (if (slot-boundp ,class-name 'value)
69     (getf (slot-value ,class-name 'value) ',x)
70     (foreign-slot-value (pointer ,class-name)
71 rklochkov 16 ',(struct-type struct-name) ',x)))
72 rklochkov 1 (unless (fboundp '(setf ,x))
73     (defgeneric (setf ,x) (val ,class-name)))
74     (defmethod (setf ,x) (val (,class-name ,class-name))
75     (if (slot-boundp ,class-name 'value)
76     (setf (getf (slot-value ,class-name 'value) ',x) val)
77     (setf (foreign-slot-value (pointer ,class-name)
78 rklochkov 16 ',(struct-type struct-name) ',x)
79 rklochkov 1 val)))
80     (save-setter ,class-name ,x)))
81 rklochkov 16 (foreign-slot-names (struct-type struct-name))))))
82 rklochkov 1
83     (defmacro defbitaccessors (class slot &rest fields)
84     (let ((pos 0))
85     (flet ((build-field (field)
86     (destructuring-bind (name type size) field
87     (prog1
88     `(progn
89     (unless (fboundp ',name)
90     (defgeneric ,name (,class)))
91     (defmethod ,name ((,class ,class))
92     (convert-from-foreign
93     (ldb (byte ,size ,pos) (slot-value ,class ',slot))
94     ,type))
95     (unless (fboundp '(setf ,name))
96     (defgeneric (setf ,name) (value ,class)))
97     (defmethod (setf ,name) (value (,class ,class))
98     (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
99     (convert-to-foreign value ,type))))
100     (incf pos size)))))
101     (cons 'progn (mapcar #'build-field fields)))))
102    
103    
104     (defmacro defcstruct* (class &body body)
105     `(progn
106     (defclass ,class (struct) ())
107     (defcstruct ,class ,@body)
108     (defcstruct-accessors ,class)
109     (init-slots ,class)))
110    
111 rklochkov 13 (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 rklochkov 16 (setf (foreign-slot-value struct (struct-type class) slot)
117 rklochkov 13 val))))
118 rklochkov 16 (foreign-slot-names (struct-type class)))))
119 rklochkov 1
120     (defun clos->new-struct (class object)
121     (if (slot-boundp object 'value)
122 rklochkov 15 ;; use make-instance, not new-struct, because gconstructor
123     ;; may be redefined
124     (let ((res (make-instance class :new-struct t)))
125     (clos->struct class object (pointer res))
126     (pointer res))
127 rklochkov 4 (pointer object)))
128 rklochkov 1
129     (defun struct->clos (class struct &optional object)
130 rklochkov 5 "Translates pointer STRUCT to object OBJECT (if not supplied, then to new
131     object).
132     I suppose, that by default it should convert data from pointer to struct.
133     Only exception is the presence of OBJECT with not boundp value"
134     (let ((%object (or object
135     (unless (null-pointer-p struct)
136 rklochkov 13 (make-instance class)))))
137 rklochkov 5 (when %object
138     (if (slot-boundp %object 'value)
139     (progn
140     (setf (slot-value %object 'value) nil)
141     (unless (null-pointer-p struct)
142 rklochkov 16 (dolist (slot (foreign-slot-names (struct-type class)))
143 rklochkov 5 (setf (getf (slot-value %object 'value) slot)
144 rklochkov 16 (foreign-slot-value struct (struct-type class) slot)))))
145 rklochkov 5 (setf (pointer %object) struct))
146     %object)))
147 rklochkov 1
148     (define-foreign-type cffi-struct (cffi-object freeable-out)
149     ()
150     (:actual-type :pointer))
151    
152 rklochkov 5 (defmethod free-sent-ptr ((type cffi-struct) ptr place)
153 rklochkov 12 (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
154 rklochkov 5 (free-struct (object-class type) ptr)))
155    
156 rklochkov 9 (defmethod free-returned-ptr ((type cffi-struct) ptr)
157     (unless (null-pointer-p ptr)
158     (free-struct (object-class type) ptr)))
159 rklochkov 5
160 rklochkov 9
161 rklochkov 1 (defmethod foreign-type-size ((type cffi-struct))
162     "Return the size in bytes of a foreign typedef."
163 rklochkov 16 (foreign-type-size (struct-type (object-class type))))
164 rklochkov 1
165 rklochkov 8 (define-parse-method struct (class &rest rest)
166     (apply #'make-instance 'cffi-struct :class class rest))
167 rklochkov 1
168     (defun %class (type value)
169     (or (object-class type) (class-name (class-of value))))
170    
171     (defmethod copy-from-foreign ((type cffi-object) ptr place)
172 rklochkov 5 (when (slot-boundp place 'value)
173 rklochkov 1 (struct->clos (%class type place) ptr place)))
174    
175 rklochkov 5 ;; cffi-object is not tyoo. It is for use struct with object designator
176 rklochkov 1 (defmethod translate-to-foreign ((value struct) (type cffi-object))
177     (values (clos->new-struct (%class type value) value) value))
178    
179     (defmethod translate-from-foreign (value (type cffi-struct))
180     (struct->clos (object-class type) value))
181    
182     ;;; Allowed use with object designator
183 rklochkov 3 ;; object == (struct nil)
184 rklochkov 1
185    
186     ;; to allow using array of structs
187 rklochkov 13 ;; (eval-when (:compile-toplevel :load-toplevel :execute)
188     ;; (unless (get 'mem-ref 'struct)
189     ;; (let ((old (fdefinition 'mem-ref)))
190     ;; (fmakunbound 'mem-ref)
191     ;; (defun mem-ref (ptr type &optional (offset 0))
192     ;; (let ((ptype (cffi::parse-type type)))
193     ;; (if (subtypep (type-of ptype) 'cffi-struct)
194     ;; (translate-from-foreign (inc-pointer ptr offset) ptype)
195     ;; (funcall old ptr type offset)))))
196     ;; (setf (get 'mem-ref 'struct) t)))
197 rklochkov 1
198 rklochkov 13 (defun struct-p (type)
199     (and (consp type) (eq (car type) 'struct)))
200 rklochkov 1
201 rklochkov 16 (defun ptr-struct (ptr type i)
202     (inc-pointer ptr (* i (foreign-type-size type))))
203    
204 rklochkov 1 (defun from-foreign (var type count)
205     "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
206     (if count
207     (let ((res (make-array count)))
208 rklochkov 13 (if (struct-p type)
209     (dotimes (i count)
210     (setf (aref res i)
211 rklochkov 16 (convert-from-foreign (ptr-struct var type i) type)))
212 rklochkov 13 (dotimes (i count)
213     (setf (aref res i)
214     (mem-aref var type i))))
215 rklochkov 1 res)
216     (mem-ref var type)))
217    
218    
219     (defmacro with-foreign-out ((var type &optional count) return-result &body body)
220     "The same as WITH-FOREIGN-OBJECT, but returns value of object"
221     (let ((value `(from-foreign ,var ,type ,count)))
222     `(with-foreign-object (,var ,type ,@(when count (list count)))
223     ,(if (eq return-result :ignore)
224     `(progn ,@body ,value)
225     `(let ((res ,@body))
226     ,(ecase return-result
227     (:if-success `(when res ,value))
228     (:return `(values res ,value))))))))
229    
230     (flet
231     ((make-with-foreign-outs (res-fun bindings return-result body)
232     (let ((values-form (mapcar (lambda (x)
233     (destructuring-bind
234     (var type &optional count) x
235     `(from-foreign ,var ,type ,count)))
236     bindings)))
237     `(with-foreign-objects ,bindings
238     ,(if (eq return-result :ignore)
239     `(progn ,@body (,res-fun ,@values-form))
240     `(let ((res ,@body))
241     ,(ecase return-result
242     (:if-success
243     `(when res (,res-fun ,@values-form)))
244     (:return
245     `(,res-fun res ,@values-form)))))))))
246    
247     (defmacro with-foreign-outs (bindings return-result &body body)
248     "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
249     of result and binded vars, RETURN-RESULT may be
250     :RETURN - return result and values
251     :IF-SUCCESS - return values if result t
252     :IGNORE - discard result"
253     (make-with-foreign-outs 'values bindings return-result body))
254    
255     (defmacro with-foreign-outs-list (bindings return-result &body body)
256     "The same as WITH-FOREIGN-OBJECTS, but returns list"
257     (make-with-foreign-outs 'list bindings return-result body)))

  ViewVC Help
Powered by ViewVC 1.1.5