Bug fix in SCALE-TO-DEVICE

[clg] / gffi / memory.lisp

diff --git a/gffi/memory.lisp b/gffi/memory.lisp
index b84cb4016ce1bb365b93a661eb2c0d84bce5de46..37120485513d7b73e793e2bb2a9d42e9be50bd39 100644 (file)
--- a/gffi/memory.lisp
+++ b/gffi/memory.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: memory.lisp,v 1.1 2006-04-25 20:31:35 espen Exp $
+;; $Id: memory.lisp,v 1.4 2007-06-02 07:26:23 espen Exp $
 
 
 (in-package "GFFI")
@@ -71,14 +71,61 @@ (defun (setf ref-byte) (byte location &optional (offset 0))
    #+clisp(ffi:memory-as location 'ffi:uchar offset)
    byte))
 
+(defun ref-int-32 (location &optional (offset 0))
+  #+(or cmu sbcl)(signed-sap-ref-32 location offset)
+  #+clisp(ffi:memory-as location 'ffi:sint32 offset))
+
+(defun (setf ref-int-32) (value location &optional (offset 0))
+  (setf 
+   #+(or cmu sbcl)(signed-sap-ref-32 location offset)
+   #+clisp(ffi:memory-as location 'ffi:sint32 offset)
+   value))
+
+(defun ref-uint-32 (location &optional (offset 0))
+  #+(or cmu sbcl)(sap-ref-32 location offset)
+  #+clisp(ffi:memory-as location 'ffi:uint32 offset))
+
+(defun (setf ref-uint-32) (value location &optional (offset 0))
+  (setf 
+   #+(or cmu sbcl)(sap-ref-32 location offset)
+   #+clisp(ffi:memory-as location 'ffi:uint32 offset)
+   value))
+
+(defun ref-single-float (location &optional (offset 0))
+  #+(or cmu sbcl)(sap-ref-single location offset)
+  #+clisp(ffi:memory-as location 'single-float offset))
+
+(defun (setf ref-single-float) (value location &optional (offset 0))
+  (setf 
+   #+(or cmu sbcl)(sap-ref-single location offset)
+   #+clisp(ffi:memory-as location 'single-float offset)
+   value))
+
+(defun ref-double-float (location &optional (offset 0))
+  #+(or cmu sbcl)(sap-ref-double location offset)
+  #+clisp(ffi:memory-as location 'double-float offset))
+
+(defun (setf ref-double-float) (value location &optional (offset 0))
+  (setf 
+   #+(or cmu sbcl)(sap-ref-double location offset)
+   #+clisp(ffi:memory-as location 'double-float offset)
+   value))
+
+
+
+(defparameter *memory-allocator* nil)
+(defparameter *memory-deallocator* nil)
+
 (defun allocate-memory (size)
-  (declare (ignore size))
-  (error "Memory allocator not set"))
+  (if *memory-allocator*
+      (funcall *memory-allocator* size)
+    (error "Memory allocator not set")))
 (declaim (ftype (function (integer) system-area-pointer) allocate-memory))
 
 (defun deallocate-memory (location)
-  (declare (ignore location))
-  (warn "Memory deallocator not set"))
+  (if *memory-deallocator*
+      (funcall *memory-deallocator* location)
+    (warn "Memory deallocator not set")))
 
 (defun copy-memory (from length &optional (to (allocate-memory length)))
   #+cmu(system-area-copy from 0 to 0 (* 8 length))
@@ -141,4 +188,9 @@   (defun sb-sizeof-bits (type)
      (sb-alien-internals:parse-alien-type type nil)))
 
   (defun sb-sizeof (type)
-    (/ (sb-sizeof-bits type) 8)))
+    (/ (sb-sizeof-bits type) 8))
+
+  (defun sb-alignment (type)
+    (/ (sb-alien-internals:alien-type-alignment
+       (sb-alien-internals:parse-alien-type type nil))
+       8)))