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 | |
bf54963e |
23 | ;; $Id: memory.lisp,v 1.3 2006-12-21 16:38:19 espen Exp $ |
b286c6ed |
24 | |
25 | |
26 | (in-package "GFFI") |
27 | |
28 | |
29 | (defun make-pointer (address) |
30 | #+(or cmu sbcl)(int-sap address) |
31 | #+clisp(ffi:unsigned-foreign-address address) |
32 | #-(or cmu sbcl clisp)address) |
33 | |
34 | (defun pointer-address (pointer) |
35 | #+(or cmu sbcl)(sap-int pointer) |
36 | #+clisp(ffi:foreign-address-unsigned pointer) |
37 | #-(or cmu sbcl clisp)pointer) |
38 | |
39 | (defun null-pointer-p (pointer) |
40 | #+(or cmu sbcl)(zerop (sap-int pointer)) |
41 | #+clisp(or (not pointer) (zerop (pointer-address pointer))) |
42 | #-(or cmu sbcl clisp)(zerop pointer)) |
43 | |
44 | (defun pointer= (pointer1 pointer2) |
45 | #+(or cmu sbcl)(sap= pointer1 pointer2) |
46 | #+clisp(= (pointer-address pointer1) (pointer-address pointer2)) |
47 | #-(or cmu sbcl clisp)(= pointer1 pointer2)) |
48 | |
49 | (defun pointer+ (pointer offset) |
50 | #+(or cmu sbcl)(sap+ pointer offset) |
51 | #+clisp(make-pointer (+ (pointer-address pointer) offset)) |
52 | #-(or cmu sbcl clisp)(+ pointer offset)) |
53 | |
54 | (defun ref-pointer (location &optional (offset 0)) |
55 | #+(or cmu sbcl)(sap-ref-sap location offset) |
56 | #+clisp(ffi:memory-as location 'ffi:c-pointer offset)) |
57 | |
58 | (defun (setf ref-pointer) (pointer location &optional (offset 0)) |
59 | (setf |
60 | #+(or cmu sbcl)(sap-ref-sap location offset) |
61 | #+clisp(ffi:memory-as location 'ffi:c-pointer offset) |
62 | pointer)) |
63 | |
64 | (defun ref-byte (location &optional (offset 0)) |
65 | #+(or cmu sbcl)(sap-ref-8 location offset) |
66 | #+clisp(ffi:memory-as location 'ffi:uchar offset)) |
67 | |
68 | (defun (setf ref-byte) (byte location &optional (offset 0)) |
69 | (setf |
70 | #+(or cmu sbcl)(sap-ref-8 location offset) |
71 | #+clisp(ffi:memory-as location 'ffi:uchar offset) |
72 | byte)) |
73 | |
bf54963e |
74 | (defparameter *memory-allocator* nil) |
75 | (defparameter *memory-deallocator* nil) |
76 | |
b286c6ed |
77 | (defun allocate-memory (size) |
bf54963e |
78 | (if *memory-allocator* |
79 | (funcall *memory-allocator* size) |
80 | (error "Memory allocator not set"))) |
b286c6ed |
81 | (declaim (ftype (function (integer) system-area-pointer) allocate-memory)) |
82 | |
83 | (defun deallocate-memory (location) |
bf54963e |
84 | (if *memory-deallocator* |
85 | (funcall *memory-deallocator* location) |
86 | (warn "Memory deallocator not set"))) |
b286c6ed |
87 | |
88 | (defun copy-memory (from length &optional (to (allocate-memory length))) |
89 | #+cmu(system-area-copy from 0 to 0 (* 8 length)) |
90 | #+sbcl(system-area-ub8-copy from 0 to 0 length) |
91 | #-(or cmu sbcl) |
92 | (loop |
93 | for offset below length |
94 | do (setf (ref-byte to offset) (ref-byte from offset))) |
95 | to) |
96 | |
97 | (defun clear-memory (from length &optional (offset 0)) |
98 | #+sbcl(system-area-ub8-fill 0 from offset length) |
99 | #-sbcl |
100 | (loop |
101 | repeat length |
102 | for byte-offset from offset |
103 | do (setf (ref-byte from byte-offset) 0))) |
104 | |
105 | (defun memory-clear-p (from length &optional (offset 0)) |
106 | (loop |
107 | repeat length |
108 | for byte-offset from offset |
109 | unless (zerop (ref-byte from byte-offset)) |
110 | do (return-from memory-clear-p nil)) |
111 | t) |
112 | |
113 | (defmacro with-memory ((var size) &body body) |
114 | #-clisp |
115 | (if (and #+(or cmu sbcl)t (constantp size)) |
116 | (let ((memory (make-symbol "MEMORY")) |
117 | (size (eval size))) |
118 | `(with-alien ((,memory (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size))) |
119 | (let ((,var (alien-sap ,memory))) |
120 | (clear-memory ,var ,size) |
121 | ,@body))) |
122 | `(let ((,var (allocate-memory ,size))) |
123 | (unwind-protect |
124 | (progn ,@body) |
125 | (deallocate-memory ,var)))) |
126 | #+clisp |
127 | (let ((memory (make-symbol "MEMORY"))) |
128 | `(ffi:with-foreign-object (,memory `(ffi:c-array ffi:uint8 ,,size)) |
129 | (let ((,var (ffi:foreign-address ,memory))) |
130 | ,@body)))) |
131 | |
132 | (defmacro with-pointer ((var &optional (pointer '(make-pointer 0))) &body body) |
133 | "Binds POINTER to VAR in a way which makes it possible to pass the location of VAR to in foreign function call." |
134 | #+(or cmu sbcl) |
135 | `(with-alien ((,var system-area-pointer ,pointer)) |
136 | ,@body) |
137 | #+clisp |
138 | `(ffi:with-c-var (,var `ffi:c-pointer ,pointer) |
139 | ,@body)) |
140 | |
141 | |
142 | #+sbcl |
143 | (progn |
144 | (defun sb-sizeof-bits (type) |
145 | (sb-alien-internals:alien-type-bits |
146 | (sb-alien-internals:parse-alien-type type nil))) |
147 | |
148 | (defun sb-sizeof (type) |
90e8bbf6 |
149 | (/ (sb-sizeof-bits type) 8)) |
150 | |
151 | (defun sb-alignment (type) |
152 | (/ (sb-alien-internals:alien-type-alignment |
153 | (sb-alien-internals:parse-alien-type type nil)) |
154 | 8))) |