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

Contents of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (hide annotations)
Fri May 4 11:25:20 2012 UTC (23 months, 1 week ago) by rklochkov
File size: 8007 byte(s)
Fixes with GC

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     (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     (slot-value object 'pointer)))
103    
104     (defun struct->clos (class struct &optional object)
105     (let ((res (or object (make-instance class))))
106     (setf (slot-value res 'value) nil)
107     (mapc (lambda (slot)
108     (setf (getf (slot-value res 'value) slot)
109     (foreign-slot-value struct class slot)))
110     (foreign-slot-names class))
111     res))
112    
113    
114    
115     (define-foreign-type cffi-struct (cffi-object freeable-out)
116     ()
117     (:actual-type :pointer))
118    
119     (defmethod free-ptr ((type cffi-struct) ptr)
120     (free-struct (object-class type) ptr))
121    
122     (defmethod foreign-type-size ((type cffi-struct))
123     "Return the size in bytes of a foreign typedef."
124     (foreign-type-size (object-class type)))
125    
126     (define-parse-method struct (class &key (free :no-transfer) out)
127     (make-instance 'cffi-struct
128     :class class :free free :out out))
129    
130     (defun %class (type value)
131     (or (object-class type) (class-name (class-of value))))
132    
133     (defmethod copy-from-foreign ((type cffi-object) ptr place)
134     (when (or (slot-boundp place 'value)
135     (member (object-free type) '(:all :transfer)))
136     (struct->clos (%class type place) ptr place)))
137    
138     (defmethod translate-to-foreign ((value struct) (type cffi-object))
139     (values (clos->new-struct (%class type value) value) value))
140    
141     (defmethod translate-from-foreign (value (type cffi-struct))
142     (struct->clos (object-class type) value))
143    
144     ;;; Allowed use with object designator
145 rklochkov 3 ;; object == (struct nil)
146 rklochkov 1
147    
148     ;; to allow using array of structs
149     (eval-when (:compile-toplevel :load-toplevel :execute)
150     (unless (get 'mem-ref 'struct)
151     (let ((old (fdefinition 'mem-ref)))
152     (fmakunbound 'mem-ref)
153     (defun mem-ref (ptr type &optional (offset 0))
154     (let ((ptype (cffi::parse-type type)))
155     (if (subtypep (type-of ptype) 'cffi-struct)
156     (translate-from-foreign (inc-pointer ptr offset) ptype)
157     (funcall old ptr type offset)))))
158     (setf (get 'mem-ref 'struct) t)))
159    
160    
161     (defun from-foreign (var type count)
162     "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
163     (if count
164     (let ((res (make-array count)))
165     (dotimes (i count)
166     (setf (aref res i)
167     (mem-aref var type i)))
168     res)
169     (mem-ref var type)))
170    
171    
172     (defmacro with-foreign-out ((var type &optional count) return-result &body body)
173     "The same as WITH-FOREIGN-OBJECT, but returns value of object"
174     (let ((value `(from-foreign ,var ,type ,count)))
175     `(with-foreign-object (,var ,type ,@(when count (list count)))
176     ,(if (eq return-result :ignore)
177     `(progn ,@body ,value)
178     `(let ((res ,@body))
179     ,(ecase return-result
180     (:if-success `(when res ,value))
181     (:return `(values res ,value))))))))
182    
183     (flet
184     ((make-with-foreign-outs (res-fun bindings return-result body)
185     (let ((values-form (mapcar (lambda (x)
186     (destructuring-bind
187     (var type &optional count) x
188     `(from-foreign ,var ,type ,count)))
189     bindings)))
190     `(with-foreign-objects ,bindings
191     ,(if (eq return-result :ignore)
192     `(progn ,@body (,res-fun ,@values-form))
193     `(let ((res ,@body))
194     ,(ecase return-result
195     (:if-success
196     `(when res (,res-fun ,@values-form)))
197     (:return
198     `(,res-fun res ,@values-form)))))))))
199    
200     (defmacro with-foreign-outs (bindings return-result &body body)
201     "The same as WITH-FOREIGN-OBJECTS, but returns (values ...)
202     of result and binded vars, RETURN-RESULT may be
203     :RETURN - return result and values
204     :IF-SUCCESS - return values if result t
205     :IGNORE - discard result"
206     (make-with-foreign-outs 'values bindings return-result body))
207    
208     (defmacro with-foreign-outs-list (bindings return-result &body body)
209     "The same as WITH-FOREIGN-OBJECTS, but returns list"
210     (make-with-foreign-outs 'list bindings return-result body)))

  ViewVC Help
Powered by ViewVC 1.1.5