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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 8 - (show annotations)
Sun Aug 12 17:36:30 2012 UTC (20 months ago) by rklochkov
File size: 8761 byte(s)
Changed API for freeable to be consistent with CFFI: 
changed :FREE to :FREE-FROM-FOREIGN and :FREE-TO-FOREIGN as in :STRING

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

  ViewVC Help
Powered by ViewVC 1.1.5