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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4 - (show annotations)
Mon May 7 17:27:22 2012 UTC (23 months, 1 week ago) by rklochkov
File size: 8194 byte(s)
Minor fixes
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 (foreign-free value)))
25
26 (defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys)
27 (if new-struct
28 (new-struct (class-name (class-of struct)))
29 (progn
30 (setf (slot-value struct 'value) nil)
31 (null-pointer))))
32
33 (defun pair (maybe-pair)
34 (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
35
36 (defmacro defcstruct-accessors (class)
37 "CLASS may be symbol = class-name = struct name,
38 or may be cons (class-name . struct-name)"
39 (destructuring-bind (class-name . struct-name) (pair class)
40 `(progn
41 (clear-setters ,class-name)
42 ,@(mapcar
43 (lambda (x)
44 `(progn
45 (unless (fboundp ',x)
46 (defgeneric ,x (,class-name)))
47 (defmethod ,x ((,class-name ,class-name))
48 (if (slot-boundp ,class-name 'value)
49 (getf (slot-value ,class-name 'value) ',x)
50 (foreign-slot-value (pointer ,class-name)
51 ',struct-name ',x)))
52 (unless (fboundp '(setf ,x))
53 (defgeneric (setf ,x) (val ,class-name)))
54 (defmethod (setf ,x) (val (,class-name ,class-name))
55 (if (slot-boundp ,class-name 'value)
56 (setf (getf (slot-value ,class-name 'value) ',x) val)
57 (setf (foreign-slot-value (pointer ,class-name)
58 ',struct-name ',x)
59 val)))
60 (save-setter ,class-name ,x)))
61 (foreign-slot-names struct-name)))))
62
63 (defmacro defbitaccessors (class slot &rest fields)
64 (let ((pos 0))
65 (flet ((build-field (field)
66 (destructuring-bind (name type size) field
67 (prog1
68 `(progn
69 (unless (fboundp ',name)
70 (defgeneric ,name (,class)))
71 (defmethod ,name ((,class ,class))
72 (convert-from-foreign
73 (ldb (byte ,size ,pos) (slot-value ,class ',slot))
74 ,type))
75 (unless (fboundp '(setf ,name))
76 (defgeneric (setf ,name) (value ,class)))
77 (defmethod (setf ,name) (value (,class ,class))
78 (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
79 (convert-to-foreign value ,type))))
80 (incf pos size)))))
81 (cons 'progn (mapcar #'build-field fields)))))
82
83
84 (defmacro defcstruct* (class &body body)
85 `(progn
86 (defclass ,class (struct) ())
87 (defcstruct ,class ,@body)
88 (defcstruct-accessors ,class)
89 (init-slots ,class)))
90
91
92 (defun clos->new-struct (class object)
93 (if (slot-boundp object 'value)
94 (let ((res (new-struct class))
95 (default (gensym)))
96 (mapc (lambda (slot)
97 (let ((val (getf (slot-value object 'value) slot default)))
98 (unless (eq val default)
99 (setf (foreign-slot-value res class slot) val))))
100 (foreign-slot-names class))
101 res)
102 (pointer object)))
103
104 (defun struct->clos (class struct &optional object)
105 (unless object
106 (return-from struct->clos
107 (unless (null-pointer-p struct)
108 (make-instance class :pointer struct))))
109 (if (slot-boundp object 'value)
110 (progn
111 (setf (slot-value object 'value) nil)
112 (mapc (lambda (slot)
113 (setf (getf (slot-value object 'value) slot)
114 (foreign-slot-value struct class slot)))
115 (foreign-slot-names class)))
116 (setf (pointer object) struct))
117 ;(break)
118 object)
119
120
121
122
123 (define-foreign-type cffi-struct (cffi-object freeable-out)
124 ()
125 (:actual-type :pointer))
126
127 (defmethod free-ptr ((type cffi-struct) ptr)
128 (free-struct (object-class type) ptr))
129
130 (defmethod foreign-type-size ((type cffi-struct))
131 "Return the size in bytes of a foreign typedef."
132 (foreign-type-size (object-class type)))
133
134 (define-parse-method struct (class &key (free :no-transfer) out)
135 (make-instance 'cffi-struct
136 :class class :free free :out out))
137
138 (defun %class (type value)
139 (or (object-class type) (class-name (class-of value))))
140
141 (defmethod copy-from-foreign ((type cffi-object) ptr place)
142 (when (or (slot-boundp place 'value)
143 (member (object-free type) '(:all :transfer)))
144 (struct->clos (%class type place) ptr place)))
145
146 (defmethod translate-to-foreign ((value struct) (type cffi-object))
147 (values (clos->new-struct (%class type value) value) value))
148
149 (defmethod translate-from-foreign (value (type cffi-struct))
150 (struct->clos (object-class type) value))
151
152 ;;; Allowed use with object designator
153 ;; object == (struct nil)
154
155
156 ;; to allow using array of structs
157 (eval-when (:compile-toplevel :load-toplevel :execute)
158 (unless (get 'mem-ref 'struct)
159 (let ((old (fdefinition 'mem-ref)))
160 (fmakunbound 'mem-ref)
161 (defun mem-ref (ptr type &optional (offset 0))
162 (let ((ptype (cffi::parse-type type)))
163 (if (subtypep (type-of ptype) 'cffi-struct)
164 (translate-from-foreign (inc-pointer ptr offset) ptype)
165 (funcall old ptr type offset)))))
166 (setf (get 'mem-ref 'struct) t)))
167
168
169 (defun from-foreign (var type count)
170 "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
171 (if count
172 (let ((res (make-array count)))
173 (dotimes (i count)
174 (setf (aref res i)
175 (mem-aref var type i)))
176 res)
177 (mem-ref var type)))
178
179
180 (defmacro with-foreign-out ((var type &optional count) return-result &body body)
181 "The same as WITH-FOREIGN-OBJECT, but returns value of object"
182 (let ((value `(from-foreign ,var ,type ,count)))
183 `(with-foreign-object (,var ,type ,@(when count (list count)))
184 ,(if (eq return-result :ignore)
185 `(progn ,@body ,value)
186 `(let ((res ,@body))
187 ,(ecase return-result
188 (:if-success `(when res ,value))
189 (:return `(values res ,value))))))))
190
191 (flet
192 ((make-with-foreign-outs (res-fun bindings return-result body)
193 (let ((values-form (mapcar (lambda (x)
194 (destructuring-bind
195 (var type &optional count) x
196 `(from-foreign ,var ,type ,count)))
197 bindings)))
198 `(with-foreign-objects ,bindings
199 ,(if (eq return-result :ignore)
200 `(progn ,@body (,res-fun ,@values-form))
201 `(let ((res ,@body))
202 ,(ecase return-result
203 (:if-success
204 `(when res (,res-fun ,@values-form)))
205 (:return
206 `(,res-fun res ,@values-form)))))))))
207
208 (defmacro with-foreign-outs (bindings return-result &body body)
209 "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
210 of result and binded vars, RETURN-RESULT may be
211 :RETURN - return result and values
212 :IF-SUCCESS - return values if result t
213 :IGNORE - discard result"
214 (make-with-foreign-outs 'values bindings return-result body))
215
216 (defmacro with-foreign-outs-list (bindings return-result &body body)
217 "The same as WITH-FOREIGN-OBJECTS, but returns list"
218 (make-with-foreign-outs 'list bindings return-result body)))

  ViewVC Help
Powered by ViewVC 1.1.5