-
Notifications
You must be signed in to change notification settings - Fork 1
/
cffi-c-ref.lisp
228 lines (202 loc) · 9.53 KB
/
cffi-c-ref.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
(cl:defpackage :cffi-c-ref
(:use :cl :alexandria)
(:export #:c-ref
#:c-let
#:c-with
#:c-val))
(cl:in-package :cffi-c-ref)
(defun symbol-for-anonymous-field-p (slot-name)
(getf (symbol-plist slot-name) :cffi-c-ref-anonymous-field))
(defun extract-slot-names (type)
(loop for slot-name in (cffi:foreign-slot-names type)
for anonymous-p = (symbol-for-anonymous-field-p slot-name)
if anonymous-p
append (extract-slot-names
(cffi:foreign-slot-type type slot-name))
else
collect slot-name))
(defun find-slot-type (type name)
(loop for slot-name in (cffi:foreign-slot-names type)
for slot-type = (cffi:foreign-slot-type type slot-name)
for anonymous-p = (symbol-for-anonymous-field-p slot-name)
thereis (or (and anonymous-p (find-slot-type slot-type name))
(and (eq name slot-name) slot-type))))
(defun find-slot-offset (type name)
(labels ((%find-slot-offset (type name offset)
(loop for slot-name in (cffi:foreign-slot-names type)
for slot-type = (cffi:foreign-slot-type type slot-name)
for slot-offset = (cffi:foreign-slot-offset type slot-name)
for anonymous-p = (symbol-for-anonymous-field-p slot-name)
thereis (or (and anonymous-p
(%find-slot-offset slot-type
name
(+ offset slot-offset)))
(and (eq name slot-name)
(+ offset slot-offset))))))
(when-let ((offset (%find-slot-offset type name 0)))
offset)))
(defun find-slot-name (type keyword-name)
(let ((slot-names (extract-slot-names type)))
(if-let ((slot (find (symbol-name keyword-name)
slot-names
:key #'symbol-name
:test #'string=)))
slot
(error "Slot with name ~A not found. Available names: ~{~A~^, ~}"
keyword-name (mapcar #'symbol-name slot-names)))))
(defun find-pointer-or-array-actual-type (type)
(let ((unparsed (cffi::unparse-type
(cffi::follow-typedefs
(cffi::parse-type type)))))
(if (listp unparsed)
(values (second unparsed) (first unparsed))
(unless (keywordp unparsed)
(find-pointer-or-array-actual-type
(cffi::unparse-type
(cffi::actual-type
(cffi::parse-type unparsed))))))))
(defun canonicalize-foreign-type (type)
(cffi::canonicalize-foreign-type type))
(defun %mem-offset (ptr type offset dynamic-offset accessors)
(labels ((%mem-offset-slot (accessor &optional next-type)
(let* ((slot-name (find-slot-name type accessor))
(next-type (or next-type (find-slot-type type slot-name)))
(next-offset (find-slot-offset type slot-name)))
(%mem-offset ptr next-type
(+ offset next-offset)
dynamic-offset
(rest accessors))))
(%mem-offset-array (accessor)
(%mem-offset ptr type
(+ offset (* (cffi:foreign-type-size type)
accessor))
dynamic-offset
(rest accessors)))
(%mem-offset-with-cast (accessor)
(destructuring-bind (slot-name slot-type)
accessor
(%mem-offset-slot slot-name slot-type)))
(%mem-offset-dynamically (accessor)
(%mem-offset ptr type
offset
(list* (if (> (cffi:foreign-type-size type) 1)
`(* ,(cffi:foreign-type-size type) ,accessor)
accessor)
dynamic-offset)
(rest accessors)))
(%expand-offset ()
(cond
((and (zerop offset) (null dynamic-offset))
0)
((and (not (zerop offset)) dynamic-offset)
`(+ ,offset ,@dynamic-offset))
((and (zerop offset) (rest dynamic-offset))
`(+ ,@dynamic-offset))
((zerop offset) (first dynamic-offset))
(t offset)))
(%mem-offset-symbol (accessor)
(switch (accessor :test #'string=)
("&" (when (rest accessors)
(error "& must be the last accessor, but more found ~S"
(rest accessors)))
(if (and (null dynamic-offset) (zerop offset))
ptr
`(cffi:inc-pointer ,ptr ,(%expand-offset))))
("*" (let ((canonical-type (canonicalize-foreign-type type)))
(unless (eq canonical-type :pointer)
(error "Cannot dereference a non-pointer ~S" type))
(multiple-value-bind (actual-type kind)
(find-pointer-or-array-actual-type type)
(when (or (not actual-type) (eq :void actual-type))
(error "Cannot dereference a void pointer"))
(%mem-offset (if (eq kind :array)
ptr
`(cffi:mem-ref ,ptr :pointer ,(%expand-offset)))
actual-type
0 nil
(rest accessors)))))
(t (%mem-offset-dynamically accessor)))))
(if accessors
(let ((accessor (first accessors)))
(etypecase accessor
(symbol (if (keywordp accessor)
(%mem-offset-slot accessor)
(%mem-offset-symbol accessor)))
(integer (%mem-offset-array accessor))
(cons (if (keywordp (first accessor))
(%mem-offset-with-cast accessor)
(%mem-offset-dynamically accessor)))))
`(cffi:mem-ref ,ptr ',type ,(%expand-offset)))))
(defmacro c-ref (ptr type &rest accessors)
(%mem-offset ptr type 0 nil accessors))
(cffi:defcfun (%memset "memset") :void
(destination (:pointer :void))
(initial-value :int)
(size :unsigned-int))
(defmacro c-let ((&rest bindings) &body body)
(with-gensyms (accessors)
(multiple-value-bind (macrolets
symbol-macrolets
allocators
deallocators
initializers
dynamic)
(loop with macrolets
with symbol-macrolets
with allocators
with deallocators
with initializers
with dynamic
for binding in bindings
do (destructuring-bind (var type &key from alloc free (count 1) clear)
binding
(when (and alloc from)
(error ":alloc and :from both found in ~A" binding))
(unless (or alloc from)
(error "Neither :alloc nor :from found in ~A" binding))
(with-gensyms (ptr)
(if (and alloc free)
(push `(,ptr ',type ,count) dynamic)
(progn
(when alloc
(push `(,ptr (cffi:foreign-alloc ',type :count ,count))
allocators))
(when free
(push `(cffi:foreign-free ,ptr) deallocators))))
(when from
(push `(,ptr ,from) allocators))
(when clear
(push `(%memset ,ptr 0 ,(if (numberp count)
(* (cffi:foreign-type-size type)
count)
`(* ,(cffi:foreign-type-size type)
,count)))
initializers))
(push `(,var (&rest ,accessors)
`(c-ref ,',ptr ,',type ,@,accessors))
macrolets)
(push `(,var (c-ref ,ptr ,type))
symbol-macrolets)))
finally (return (values macrolets
symbol-macrolets
allocators
deallocators
initializers
dynamic)))
`(let ,allocators
(,@(if dynamic `(cffi:with-foreign-objects ,dynamic) '(progn))
(,@(if macrolets `(macrolet ,macrolets) '(progn))
(,@(if symbol-macrolets `(symbol-macrolet ,symbol-macrolets) '(progn))
(,(if deallocators 'unwind-protect 'progn)
(progn
,@initializers
,@body)
,@deallocators))))))))
(defmacro c-with ((&rest bindings) &body body)
`(c-let ,(loop for (var type . rest) in bindings
collect `(,var ,type :alloc t :free t ,@rest))
,@body))
(defmacro c-val ((&rest bindings) &body body)
`(c-let ,(loop for (var type) in bindings
collect `(,var ,type :from ,var))
,@body))