1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: memory.lisp,v 1.7 2007-12-11 12:01:34 espen Exp $
29 #+(or cmu sbcl) 'system-area-pointer
30 #+clisp 'ffi:foreign-address)
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)
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)
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))
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))
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))
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))
61 (defun (setf ref-pointer) (pointer location &optional (offset 0))
63 #+(or cmu sbcl)(sap-ref-sap location offset)
64 #+clisp(ffi:memory-as location 'ffi:c-pointer offset)
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))
78 (ftype (function (pointer &optional fixnum) int-8) 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))
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))
89 #+(or cmu sbcl)(signed-sap-ref-8 location offset)
90 #+clisp(ffi:memory-as location 'ffi:char offset)
93 ;; Deprecated functions
94 (defun ref-byte (location &optional (offset 0))
95 (ref-int-8 location offset))
96 (defun (setf ref-byte) (byte location &optional (offset 0))
97 (setf (ref-int-8 location offset) byte))
101 (ftype (function (pointer &optional fixnum) uint-8) ref-uint-8)
103 (defun ref-uint-8 (location &optional (offset 0))
104 #+(or cmu sbcl)(sap-ref-8 location offset)
105 #+clisp(ffi:memory-as location 'ffi:uchar offset))
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))
112 #+(or cmu sbcl)(sap-ref-8 location offset)
113 #+clisp(ffi:memory-as location 'ffi:uchar offset)
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))
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))
131 #+(or cmu sbcl)(signed-sap-ref-16 location offset)
132 #+clisp(ffi:memory-as location 'ffi:sint16 offset)
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)
140 #+clisp(ffi:memory-as location 'ffi:uint16 offset))
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))
149 #+(or cmu sbcl)(sap-ref-16 location offset)
150 #+clisp(ffi:memory-as location 'ffi:uint16 offset)
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))
158 #+(or cmu sbcl)(signed-sap-ref-32 location offset)
159 #+clisp(ffi:memory-as location 'ffi:sint32 offset))
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))
166 #+(or cmu sbcl)(signed-sap-ref-32 location offset)
167 #+clisp(ffi:memory-as location 'ffi:sint32 offset)
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))
174 #+(or cmu sbcl)(sap-ref-32 location offset)
175 #+clisp(ffi:memory-as location 'ffi:uint32 offset))
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))
184 #+(or cmu sbcl)(sap-ref-32 location offset)
185 #+clisp(ffi:memory-as location 'ffi:uint32 offset)
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))
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))
201 #+(or cmu sbcl)(signed-sap-ref-64 location offset)
202 #+clisp(ffi:memory-as location 'ffi:sint64 offset)
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))
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))
219 #+(or cmu sbcl)(sap-ref-64 location offset)
220 #+clisp(ffi:memory-as location 'ffi:uint64 offset)
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))
228 #+(or cmu sbcl)(sap-ref-single location offset)
229 #+clisp(ffi:memory-as location 'single-float offset))
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))
238 #+(or cmu sbcl)(sap-ref-single location offset)
239 #+clisp(ffi:memory-as location 'single-float offset)
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))
246 #+(or cmu sbcl)(sap-ref-double location offset)
247 #+clisp(ffi:memory-as location 'double-float offset))
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))
256 #+(or cmu sbcl)(sap-ref-double location offset)
257 #+clisp(ffi:memory-as location 'double-float offset)
261 (defparameter *memory-allocator* nil)
262 (defparameter *memory-deallocator* nil)
264 (defun allocate-memory (size)
265 (if *memory-allocator*
266 (funcall *memory-allocator* size)
267 (error "Memory allocator not set")))
269 (defun deallocate-memory (location)
270 (if *memory-deallocator*
271 (funcall *memory-deallocator* location)
272 (warn "Memory deallocator not set")))
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)
279 for offset below length
280 do (setf (ref-uint-8 to offset) (ref-uint-8 from offset)))
283 (defun clear-memory (from length &optional (offset 0))
284 #+sbcl(system-area-ub8-fill 0 from offset length)
288 for byte-offset from offset
289 do (setf (ref-uint-8 from byte-offset) 0)))
291 (defun memory-clear-p (from length &optional (offset 0))
294 for byte-offset from offset
295 unless (zerop (ref-uint-8 from byte-offset))
296 do (return-from memory-clear-p nil))
299 (defmacro with-memory ((var size) &body body)
301 (if (and #+(or cmu sbcl)t (constantp size))
302 (let ((memory (make-symbol "MEMORY"))
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)
308 `(let ((,var (allocate-memory ,size)))
311 (deallocate-memory ,var))))
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)))
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."
321 `(with-alien ((,var system-area-pointer ,pointer))
324 `(ffi:with-c-var (,var `ffi:c-pointer ,pointer)
330 (defun sb-sizeof-bits (type)
331 (sb-alien-internals:alien-type-bits
332 (sb-alien-internals:parse-alien-type type nil)))
334 (defun sb-sizeof (type)
335 (/ (sb-sizeof-bits type) 8))
337 (defun sb-alignment (type)
338 (/ (sb-alien-internals:alien-type-alignment
339 (sb-alien-internals:parse-alien-type type nil))
343 (deftype endian () '(member :native :little :big))
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))))
351 (declaim (inline ,get-swapped) (inline ,set-swapped))
352 (defbinding ,get-swapped () ,type
355 (defbinding ,set-swapped () nil
360 (ftype (function (pointer &optional fixnum endian) ,type) ,ref)
362 (defun ,ref (location &optional offset (endian :native))
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))))
370 (function (,type pointer &optional fixnum endian) ,type)
372 (inline (setf ,ref)))
373 (defun (setf ,ref) (value location &optional offset (endian :native))
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)