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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 13 - (hide annotations)
Sat Dec 22 19:24:45 2012 UTC (15 months, 3 weeks ago) by rklochkov
File size: 9226 byte(s)
Fixed array. Removed redefinition of cffi:mem-ref
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     (foreign-alloc class)))
20    
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     (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 rklochkov 5 (setf (slot-value struct 'free-after) nil)
34 rklochkov 1 (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 rklochkov 8 '(:struct ,struct-name) ',x)))
55 rklochkov 1 (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 rklochkov 8 '(:struct ,struct-name) ',x)
62 rklochkov 1 val)))
63     (save-setter ,class-name ,x)))
64 rklochkov 8 (foreign-slot-names `(:struct ,struct-name))))))
65 rklochkov 1
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 rklochkov 13 (defun clos->struct (class object struct)
95     (let ((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 struct (list :struct class) slot)
100     val))))
101     (foreign-slot-names (list :struct class)))))
102 rklochkov 1
103     (defun clos->new-struct (class object)
104     (if (slot-boundp object 'value)
105 rklochkov 13 (let ((res (new-struct class)))
106     (clos->struct class object res)
107 rklochkov 1 res)
108 rklochkov 4 (pointer object)))
109 rklochkov 1
110     (defun struct->clos (class struct &optional object)
111 rklochkov 5 "Translates pointer STRUCT to object OBJECT (if not supplied, then to new
112     object).
113     I suppose, that by default it should convert data from pointer to struct.
114     Only exception is the presence of OBJECT with not boundp value"
115     (let ((%object (or object
116     (unless (null-pointer-p struct)
117 rklochkov 13 (make-instance class)))))
118 rklochkov 5 (when %object
119     (if (slot-boundp %object 'value)
120     (progn
121     (setf (slot-value %object 'value) nil)
122     (unless (null-pointer-p struct)
123 rklochkov 13 (dolist (slot (foreign-slot-names (list :struct class)))
124 rklochkov 5 (setf (getf (slot-value %object 'value) slot)
125 rklochkov 12 (foreign-slot-value struct (list :struct class) slot)))))
126 rklochkov 5 (setf (pointer %object) struct))
127     %object)))
128 rklochkov 1
129     (define-foreign-type cffi-struct (cffi-object freeable-out)
130     ()
131     (:actual-type :pointer))
132    
133 rklochkov 5 (defmethod free-sent-ptr ((type cffi-struct) ptr place)
134 rklochkov 12 (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
135 rklochkov 5 (free-struct (object-class type) ptr)))
136    
137 rklochkov 9 (defmethod free-returned-ptr ((type cffi-struct) ptr)
138     (unless (null-pointer-p ptr)
139     (free-struct (object-class type) ptr)))
140 rklochkov 5
141 rklochkov 9
142 rklochkov 1 (defmethod foreign-type-size ((type cffi-struct))
143     "Return the size in bytes of a foreign typedef."
144 rklochkov 13 (foreign-type-size (list :struct (object-class type))))
145 rklochkov 1
146 rklochkov 8 (define-parse-method struct (class &rest rest)
147     (apply #'make-instance 'cffi-struct :class class rest))
148 rklochkov 1
149     (defun %class (type value)
150     (or (object-class type) (class-name (class-of value))))
151    
152     (defmethod copy-from-foreign ((type cffi-object) ptr place)
153 rklochkov 5 (when (slot-boundp place 'value)
154 rklochkov 1 (struct->clos (%class type place) ptr place)))
155    
156 rklochkov 5 ;; cffi-object is not tyoo. It is for use struct with object designator
157 rklochkov 1 (defmethod translate-to-foreign ((value struct) (type cffi-object))
158     (values (clos->new-struct (%class type value) value) value))
159    
160     (defmethod translate-from-foreign (value (type cffi-struct))
161     (struct->clos (object-class type) value))
162    
163     ;;; Allowed use with object designator
164 rklochkov 3 ;; object == (struct nil)
165 rklochkov 1
166    
167     ;; to allow using array of structs
168 rklochkov 13 ;; (eval-when (:compile-toplevel :load-toplevel :execute)
169     ;; (unless (get 'mem-ref 'struct)
170     ;; (let ((old (fdefinition 'mem-ref)))
171     ;; (fmakunbound 'mem-ref)
172     ;; (defun mem-ref (ptr type &optional (offset 0))
173     ;; (let ((ptype (cffi::parse-type type)))
174     ;; (if (subtypep (type-of ptype) 'cffi-struct)
175     ;; (translate-from-foreign (inc-pointer ptr offset) ptype)
176     ;; (funcall old ptr type offset)))))
177     ;; (setf (get 'mem-ref 'struct) t)))
178 rklochkov 1
179 rklochkov 13 (defun struct-p (type)
180     (and (consp type) (eq (car type) 'struct)))
181 rklochkov 1
182     (defun from-foreign (var type count)
183     "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
184     (if count
185     (let ((res (make-array count)))
186 rklochkov 13 (if (struct-p type)
187     (dotimes (i count)
188     (setf (aref res i)
189     (convert-from-foreign (mem-aptr var type i) type)))
190     (dotimes (i count)
191     (setf (aref res i)
192     (mem-aref var type i))))
193 rklochkov 1 res)
194     (mem-ref var type)))
195    
196    
197     (defmacro with-foreign-out ((var type &optional count) return-result &body body)
198     "The same as WITH-FOREIGN-OBJECT, but returns value of object"
199     (let ((value `(from-foreign ,var ,type ,count)))
200     `(with-foreign-object (,var ,type ,@(when count (list count)))
201     ,(if (eq return-result :ignore)
202     `(progn ,@body ,value)
203     `(let ((res ,@body))
204     ,(ecase return-result
205     (:if-success `(when res ,value))
206     (:return `(values res ,value))))))))
207    
208     (flet
209     ((make-with-foreign-outs (res-fun bindings return-result body)
210     (let ((values-form (mapcar (lambda (x)
211     (destructuring-bind
212     (var type &optional count) x
213     `(from-foreign ,var ,type ,count)))
214     bindings)))
215     `(with-foreign-objects ,bindings
216     ,(if (eq return-result :ignore)
217     `(progn ,@body (,res-fun ,@values-form))
218     `(let ((res ,@body))
219     ,(ecase return-result
220     (:if-success
221     `(when res (,res-fun ,@values-form)))
222     (:return
223     `(,res-fun res ,@values-form)))))))))
224    
225     (defmacro with-foreign-outs (bindings return-result &body body)
226     "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
227     of result and binded vars, RETURN-RESULT may be
228     :RETURN - return result and values
229     :IF-SUCCESS - return values if result t
230     :IGNORE - discard result"
231     (make-with-foreign-outs 'values bindings return-result body))
232    
233     (defmacro with-foreign-outs-list (bindings return-result &body body)
234     "The same as WITH-FOREIGN-OBJECTS, but returns list"
235     (make-with-foreign-outs 'list bindings return-result body)))

  ViewVC Help
Powered by ViewVC 1.1.5