b286c6ed |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
11 | ;; |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
14 | ;; |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
234fd886 |
23 | ;; $Id: memory.lisp,v 1.7 2007-12-11 12:01:34 espen Exp $ |
b286c6ed |
24 | |
25 | |
26 | (in-package "GFFI") |
27 | |
2c708568 |
28 | (deftype pointer () |
29 | #+(or cmu sbcl) 'system-area-pointer |
30 | #+clisp 'ffi:foreign-address) |
b286c6ed |
31 | |
32 | (defun make-pointer (address) |
33 | #+(or cmu sbcl)(int-sap address) |
34 | #+clisp(ffi:unsigned-foreign-address address) |
35 | #-(or cmu sbcl clisp)address) |
36 | |
37 | (defun pointer-address (pointer) |
38 | #+(or cmu sbcl)(sap-int pointer) |
39 | #+clisp(ffi:foreign-address-unsigned pointer) |
40 | #-(or cmu sbcl clisp)pointer) |
41 | |
42 | (defun null-pointer-p (pointer) |
43 | #+(or cmu sbcl)(zerop (sap-int pointer)) |
44 | #+clisp(or (not pointer) (zerop (pointer-address pointer))) |
45 | #-(or cmu sbcl clisp)(zerop pointer)) |
46 | |
47 | (defun pointer= (pointer1 pointer2) |
48 | #+(or cmu sbcl)(sap= pointer1 pointer2) |
49 | #+clisp(= (pointer-address pointer1) (pointer-address pointer2)) |
50 | #-(or cmu sbcl clisp)(= pointer1 pointer2)) |
51 | |
52 | (defun pointer+ (pointer offset) |
53 | #+(or cmu sbcl)(sap+ pointer offset) |
54 | #+clisp(make-pointer (+ (pointer-address pointer) offset)) |
55 | #-(or cmu sbcl clisp)(+ pointer offset)) |
56 | |
57 | (defun ref-pointer (location &optional (offset 0)) |
58 | #+(or cmu sbcl)(sap-ref-sap location offset) |
59 | #+clisp(ffi:memory-as location 'ffi:c-pointer offset)) |
60 | |
61 | (defun (setf ref-pointer) (pointer location &optional (offset 0)) |
62 | (setf |
63 | #+(or cmu sbcl)(sap-ref-sap location offset) |
64 | #+clisp(ffi:memory-as location 'ffi:c-pointer offset) |
65 | pointer)) |
66 | |
2c708568 |
67 | |
68 | (deftype int-8 () '(signed-byte 8)) |
69 | (deftype uint-8 () '(unsigned-byte 8)) |
70 | (deftype int-16 () '(signed-byte 16)) |
71 | (deftype uint-16 () '(unsigned-byte 16)) |
72 | (deftype int-32 () '(signed-byte 32)) |
73 | (deftype uint-32 () '(unsigned-byte 32)) |
74 | (deftype int-64 () '(signed-byte 64)) |
75 | (deftype uint-64 () '(unsigned-byte 64)) |
76 | |
77 | (declaim |
78 | (ftype (function (pointer &optional fixnum) int-8) ref-int-8) |
79 | (inline ref-int-8)) |
80 | (defun ref-int-8 (location &optional (offset 0)) |
81 | #+(or cmu sbcl)(signed-sap-ref-8 location offset) |
82 | #+clisp(ffi:memory-as location 'ffi:char offset)) |
83 | |
84 | (declaim |
85 | (ftype (function (int-8 pointer &optional fixnum) int-8) (setf ref-int-8)) |
86 | (inline (setf ref-int-8))) |
87 | (defun (setf ref-int-8) (byte location &optional (offset 0)) |
88 | (setf |
89 | #+(or cmu sbcl)(signed-sap-ref-8 location offset) |
90 | #+clisp(ffi:memory-as location 'ffi:char offset) |
91 | byte)) |
92 | |
93 | ;; Deprecated functions |
b286c6ed |
94 | (defun ref-byte (location &optional (offset 0)) |
2c708568 |
95 | (ref-int-8 location offset)) |
96 | (defun (setf ref-byte) (byte location &optional (offset 0)) |
97 | (setf (ref-int-8 location offset) byte)) |
98 | |
99 | |
100 | (declaim |
101 | (ftype (function (pointer &optional fixnum) uint-8) ref-uint-8) |
102 | (inline ref-uint-8)) |
103 | (defun ref-uint-8 (location &optional (offset 0)) |
b286c6ed |
104 | #+(or cmu sbcl)(sap-ref-8 location offset) |
105 | #+clisp(ffi:memory-as location 'ffi:uchar offset)) |
106 | |
2c708568 |
107 | (declaim |
108 | (ftype (function (uint-8 pointer &optional fixnum) uint-8) (setf ref-uint-8)) |
109 | (inline (setf ref-uint-8))) |
110 | (defun (setf ref-uint-8) (byte location &optional (offset 0)) |
b286c6ed |
111 | (setf |
112 | #+(or cmu sbcl)(sap-ref-8 location offset) |
113 | #+clisp(ffi:memory-as location 'ffi:uchar offset) |
114 | byte)) |
115 | |
2c708568 |
116 | |
117 | (declaim |
118 | (ftype (function (pointer &optional fixnum) int-16) ref-native-int-16) |
119 | (inline ref-native-int-16)) |
120 | (defun ref-native-int-16 (location &optional (offset 0)) |
121 | #+(or cmu sbcl)(signed-sap-ref-16 location offset) |
122 | #+clisp(ffi:memory-as location 'ffi:sint16 offset)) |
123 | |
124 | (declaim |
125 | (ftype |
126 | (function (uint-16 pointer &optional fixnum) int-16) |
127 | (setf ref-native-int-16)) |
128 | (inline (setf ref-native-int-16))) |
129 | (defun (setf ref-native-int-16) (value location &optional (offset 0)) |
130 | (setf |
131 | #+(or cmu sbcl)(signed-sap-ref-16 location offset) |
132 | #+clisp(ffi:memory-as location 'ffi:sint16 offset) |
133 | value)) |
134 | |
135 | (declaim |
136 | (ftype (function (pointer &optional fixnum) uint-16) ref-native-uint-16) |
137 | (inline ref-native-uint-16)) |
138 | (defun ref-native-uint-16 (location &optional (offset 0)) |
139 | #+(or cmu sbcl)(sap-ref-16 location offset) |
d33e712b |
140 | #+clisp(ffi:memory-as location 'ffi:uint16 offset)) |
2c708568 |
141 | |
142 | (declaim |
143 | (ftype |
144 | (function (uint-16 pointer &optional fixnum) uint-16) |
145 | (setf ref-native-uint-16)) |
146 | (inline (setf ref-native-uint-16))) |
147 | (defun (setf ref-native-uint-16) (value location &optional (offset 0)) |
148 | (setf |
149 | #+(or cmu sbcl)(sap-ref-16 location offset) |
d33e712b |
150 | #+clisp(ffi:memory-as location 'ffi:uint16 offset) |
2c708568 |
151 | value)) |
152 | |
153 | |
154 | (declaim |
155 | (ftype (function (pointer &optional fixnum) int-32) ref-native-int-32) |
156 | (inline ref-native-int-32)) |
157 | (defun ref-native-int-32 (location &optional (offset 0)) |
b31b6b03 |
158 | #+(or cmu sbcl)(signed-sap-ref-32 location offset) |
159 | #+clisp(ffi:memory-as location 'ffi:sint32 offset)) |
160 | |
2c708568 |
161 | (declaim |
162 | (ftype (function (int-32 pointer &optional fixnum) int-32) (setf ref-native-int-32)) |
163 | (inline (setf ref-native-int-32))) |
164 | (defun (setf ref-native-int-32) (value location &optional (offset 0)) |
b31b6b03 |
165 | (setf |
166 | #+(or cmu sbcl)(signed-sap-ref-32 location offset) |
167 | #+clisp(ffi:memory-as location 'ffi:sint32 offset) |
168 | value)) |
169 | |
2c708568 |
170 | (declaim |
171 | (ftype (function (pointer &optional fixnum) uint-32) ref-native-uint-32) |
172 | (inline ref-native-uint-32)) |
173 | (defun ref-native-uint-32 (location &optional (offset 0)) |
b31b6b03 |
174 | #+(or cmu sbcl)(sap-ref-32 location offset) |
175 | #+clisp(ffi:memory-as location 'ffi:uint32 offset)) |
176 | |
2c708568 |
177 | (declaim |
178 | (ftype |
179 | (function (uint-32 pointer &optional fixnum) uint-32) |
180 | (setf ref-native-uint-32)) |
181 | (inline (setf ref-native-uint-32))) |
182 | (defun (setf ref-native-uint-32) (value location &optional (offset 0)) |
b31b6b03 |
183 | (setf |
184 | #+(or cmu sbcl)(sap-ref-32 location offset) |
185 | #+clisp(ffi:memory-as location 'ffi:uint32 offset) |
186 | value)) |
187 | |
2c708568 |
188 | |
189 | (declaim |
190 | (ftype (function (pointer &optional fixnum) int-64) ref-native-int-64) |
191 | (inline ref-native-int-64)) |
192 | (defun ref-native-int-64 (location &optional (offset 0)) |
193 | #+(or cmu sbcl)(signed-sap-ref-64 location offset) |
194 | #+clisp(ffi:memory-as location 'ffi:sint64 offset)) |
195 | |
196 | (declaim |
197 | (ftype (function (int-64 pointer &optional fixnum) int-64) (setf ref-native-int-64)) |
198 | (inline (setf ref-native-int-64))) |
199 | (defun (setf ref-native-int-64) (value location &optional (offset 0)) |
200 | (setf |
201 | #+(or cmu sbcl)(signed-sap-ref-64 location offset) |
202 | #+clisp(ffi:memory-as location 'ffi:sint64 offset) |
203 | value)) |
204 | |
205 | (declaim |
206 | (ftype (function (pointer &optional fixnum) uint-64) ref-native-uint-64) |
207 | (inline ref-native-uint-64)) |
208 | (defun ref-native-uint-64 (location &optional (offset 0)) |
209 | #+(or cmu sbcl)(sap-ref-64 location offset) |
210 | #+clisp(ffi:memory-as location 'ffi:uint64 offset)) |
211 | |
212 | (declaim |
213 | (ftype |
214 | (function (uint-64 pointer &optional fixnum) uint-64) |
215 | (setf ref-native-uint-64)) |
216 | (inline (setf ref-native-uint-64))) |
217 | (defun (setf ref-native-uint-64) (value location &optional (offset 0)) |
218 | (setf |
219 | #+(or cmu sbcl)(sap-ref-64 location offset) |
220 | #+clisp(ffi:memory-as location 'ffi:uint64 offset) |
221 | value)) |
222 | |
223 | |
224 | (declaim |
225 | (ftype (function (pointer &optional fixnum) single-float) ref-native-single-float) |
226 | (inline ref-native-single-float)) |
227 | (defun ref-native-single-float (location &optional (offset 0)) |
b31b6b03 |
228 | #+(or cmu sbcl)(sap-ref-single location offset) |
229 | #+clisp(ffi:memory-as location 'single-float offset)) |
230 | |
2c708568 |
231 | (declaim |
232 | (ftype |
233 | (function (single-float pointer &optional fixnum) single-float) |
234 | (setf ref-native-single-float)) |
235 | (inline (setf ref-native-single-float))) |
236 | (defun (setf ref-native-single-float) (value location &optional (offset 0)) |
b31b6b03 |
237 | (setf |
238 | #+(or cmu sbcl)(sap-ref-single location offset) |
239 | #+clisp(ffi:memory-as location 'single-float offset) |
240 | value)) |
241 | |
2c708568 |
242 | (declaim |
243 | (ftype (function (pointer &optional fixnum) double-float) ref-native-double-float) |
244 | (inline ref-native-double-float)) |
245 | (defun ref-native-double-float (location &optional (offset 0)) |
b31b6b03 |
246 | #+(or cmu sbcl)(sap-ref-double location offset) |
247 | #+clisp(ffi:memory-as location 'double-float offset)) |
248 | |
2c708568 |
249 | (declaim |
250 | (ftype |
251 | (function (double-float pointer &optional fixnum) double-float) |
252 | (setf ref-native-double-float)) |
253 | (inline (setf ref-native-double-float))) |
254 | (defun (setf ref-native-double-float) (value location &optional (offset 0)) |
b31b6b03 |
255 | (setf |
256 | #+(or cmu sbcl)(sap-ref-double location offset) |
257 | #+clisp(ffi:memory-as location 'double-float offset) |
258 | value)) |
259 | |
260 | |
bf54963e |
261 | (defparameter *memory-allocator* nil) |
262 | (defparameter *memory-deallocator* nil) |
263 | |
b286c6ed |
264 | (defun allocate-memory (size) |
bf54963e |
265 | (if *memory-allocator* |
266 | (funcall *memory-allocator* size) |
267 | (error "Memory allocator not set"))) |
b286c6ed |
268 | |
269 | (defun deallocate-memory (location) |
bf54963e |
270 | (if *memory-deallocator* |
271 | (funcall *memory-deallocator* location) |
272 | (warn "Memory deallocator not set"))) |
b286c6ed |
273 | |
274 | (defun copy-memory (from length &optional (to (allocate-memory length))) |
275 | #+cmu(system-area-copy from 0 to 0 (* 8 length)) |
276 | #+sbcl(system-area-ub8-copy from 0 to 0 length) |
277 | #-(or cmu sbcl) |
278 | (loop |
279 | for offset below length |
234fd886 |
280 | do (setf (ref-uint-8 to offset) (ref-uint-8 from offset))) |
b286c6ed |
281 | to) |
282 | |
283 | (defun clear-memory (from length &optional (offset 0)) |
284 | #+sbcl(system-area-ub8-fill 0 from offset length) |
285 | #-sbcl |
286 | (loop |
287 | repeat length |
288 | for byte-offset from offset |
2c708568 |
289 | do (setf (ref-uint-8 from byte-offset) 0))) |
b286c6ed |
290 | |
291 | (defun memory-clear-p (from length &optional (offset 0)) |
292 | (loop |
293 | repeat length |
294 | for byte-offset from offset |
2c708568 |
295 | unless (zerop (ref-uint-8 from byte-offset)) |
b286c6ed |
296 | do (return-from memory-clear-p nil)) |
297 | t) |
298 | |
299 | (defmacro with-memory ((var size) &body body) |
300 | #-clisp |
301 | (if (and #+(or cmu sbcl)t (constantp size)) |
302 | (let ((memory (make-symbol "MEMORY")) |
303 | (size (eval size))) |
304 | `(with-alien ((,memory (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size))) |
305 | (let ((,var (alien-sap ,memory))) |
306 | (clear-memory ,var ,size) |
307 | ,@body))) |
308 | `(let ((,var (allocate-memory ,size))) |
309 | (unwind-protect |
310 | (progn ,@body) |
311 | (deallocate-memory ,var)))) |
312 | #+clisp |
313 | (let ((memory (make-symbol "MEMORY"))) |
314 | `(ffi:with-foreign-object (,memory `(ffi:c-array ffi:uint8 ,,size)) |
315 | (let ((,var (ffi:foreign-address ,memory))) |
316 | ,@body)))) |
317 | |
318 | (defmacro with-pointer ((var &optional (pointer '(make-pointer 0))) &body body) |
319 | "Binds POINTER to VAR in a way which makes it possible to pass the location of VAR to in foreign function call." |
320 | #+(or cmu sbcl) |
321 | `(with-alien ((,var system-area-pointer ,pointer)) |
322 | ,@body) |
323 | #+clisp |
324 | `(ffi:with-c-var (,var `ffi:c-pointer ,pointer) |
325 | ,@body)) |
326 | |
327 | |
328 | #+sbcl |
329 | (progn |
330 | (defun sb-sizeof-bits (type) |
331 | (sb-alien-internals:alien-type-bits |
332 | (sb-alien-internals:parse-alien-type type nil))) |
333 | |
334 | (defun sb-sizeof (type) |
90e8bbf6 |
335 | (/ (sb-sizeof-bits type) 8)) |
336 | |
337 | (defun sb-alignment (type) |
338 | (/ (sb-alien-internals:alien-type-alignment |
339 | (sb-alien-internals:parse-alien-type type nil)) |
340 | 8))) |
2c708568 |
341 | |
342 | |
343 | (deftype endian () '(member :native :little :big)) |
344 | |
345 | (defmacro define-memory-accessor (type) |
346 | (let* ((get-swapped (intern (format nil "GET-~A-SWAPPED" type))) |
347 | (set-swapped (intern (format nil "SET-~A-SWAPPED" type))) |
348 | (ref (intern (format nil "REF-~A" type))) |
349 | (ref-native (intern (format nil "REF-NATIVE-~A" type)))) |
350 | `(progn |
351 | (declaim (inline ,get-swapped) (inline ,set-swapped)) |
352 | (defbinding ,get-swapped () ,type |
353 | (location pointer) |
354 | (offset int)) |
355 | (defbinding ,set-swapped () nil |
356 | (location pointer) |
357 | (offset int) |
358 | (value ,type)) |
359 | (declaim |
360 | (ftype (function (pointer &optional fixnum endian) ,type) ,ref) |
361 | (inline ,ref)) |
362 | (defun ,ref (location &optional offset (endian :native)) |
363 | (ecase endian |
364 | ((:native #-big-endian :little #+big-endian :big) |
365 | (,ref-native location offset)) |
366 | ((#-big-endian :big #+big-endian :little) |
367 | (,get-swapped location offset)))) |
368 | (declaim |
369 | (ftype |
370 | (function (,type pointer &optional fixnum endian) ,type) |
371 | (setf ,ref)) |
372 | (inline (setf ,ref))) |
373 | (defun (setf ,ref) (value location &optional offset (endian :native)) |
374 | (ecase endian |
375 | ((:native #-big-endian :little #+big-endian :big) |
376 | (setf (,ref-native location offset) value)) |
377 | ((#-big-endian :big #+big-endian :little) |
378 | (,set-swapped location offset value) |
379 | value)))))) |