Fix compilation for Gtk with the new, stricter inheritance

[clg] / gffi / memory.lisp

diff --git a/gffi/memory.lisp b/gffi/memory.lisp
index c58b37ac439126b15a1551271ac1f7014ec00959..7c8f458b11b39d8c06e3b89e9ac9ce70e433a06c 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.5 2007-09-07 07:28:42 espen Exp $
+;; $Id: memory.lisp,v 1.8 2008-04-29 22:11:35 espen Exp $
 
 
 (in-package "GFFI")
@@ -137,7 +137,7 @@ (declaim
  (inline ref-native-uint-16))
 (defun ref-native-uint-16 (location &optional (offset 0))
   #+(or cmu sbcl)(sap-ref-16 location offset)
-  #+clisp(ffi:memory-as location 'ffi:int16 offset))
+  #+clisp(ffi:memory-as location 'ffi:uint16 offset))
 
 (declaim 
  (ftype 
@@ -147,7 +147,7 @@ (declaim
 (defun (setf ref-native-uint-16) (value location &optional (offset 0))
   (setf 
    #+(or cmu sbcl)(sap-ref-16 location offset)
-   #+clisp(ffi:memory-as location 'ffi:int16 offset)
+   #+clisp(ffi:memory-as location 'ffi:uint16 offset)
    value))
 
 
@@ -258,8 +258,8 @@ (defun (setf ref-native-double-float) (value location &optional (offset 0))
    value))
 
 
-(defparameter *memory-allocator* nil)
-(defparameter *memory-deallocator* nil)
+(defvar *memory-allocator* nil)
+(defvar *memory-deallocator* nil)
 
 (defun allocate-memory (size)
   (if *memory-allocator*
@@ -277,7 +277,7 @@ (defun copy-memory (from length &optional (to (allocate-memory length)))
   #-(or cmu sbcl)
   (loop
    for offset below length
-   do (setf (ref-uint-88 to offset) (ref-uint-8 from offset)))
+   do (setf (ref-uint-8 to offset) (ref-uint-8 from offset)))
   to)
 
 (defun clear-memory (from length &optional (offset 0))
@@ -297,23 +297,26 @@ (defun memory-clear-p (from length &optional (offset 0))
   t)
 
 (defmacro with-memory ((var size) &body body)
-  #-clisp
-  (if (and #+(or cmu sbcl)t (constantp size))
-      (let ((memory (make-symbol "MEMORY"))
-           (size (eval size)))
-       `(with-alien ((,memory (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size)))
-          (let ((,var (alien-sap ,memory)))
-            (clear-memory ,var ,size)
-            ,@body)))
-    `(let ((,var (allocate-memory ,size)))
-       (unwind-protect
-          (progn ,@body)
-        (deallocate-memory ,var))))
-  #+clisp
-  (let ((memory (make-symbol "MEMORY")))          
-    `(ffi:with-foreign-object (,memory `(ffi:c-array ffi:uint8 ,,size))
-       (let ((,var (ffi:foreign-address ,memory)))
-        ,@body))))
+  (cond
+    #+(or cmu sbcl)
+    ((constantp size)
+     (let ((memory (make-symbol "MEMORY"))
+          (size (eval size)))
+       `(with-alien ((,memory (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size)))
+         (let ((,var (alien-sap ,memory)))
+           (clear-memory ,var ,size)
+           ,@body))))
+    (t
+     #-clisp
+     `(let ((,var (allocate-memory ,size)))
+       (unwind-protect
+            (progn ,@body)
+         (deallocate-memory ,var)))
+     #+clisp
+     (let ((memory (make-symbol "MEMORY")))       
+       `(ffi:with-foreign-object (,memory `(ffi:c-array ffi:uint8 ,,size))
+         (let ((,var (ffi:foreign-address ,memory)))
+           ,@body))))))
 
 (defmacro with-pointer ((var &optional (pointer '(make-pointer 0))) &body body)
   "Binds POINTER to VAR in a way which makes it possible to pass the location of VAR to in foreign function call."
@@ -377,3 +380,9 @@        (defun (setf ,ref) (value location &optional offset (endian :native))
           ((#-big-endian :big #+big-endian :little)
            (,set-swapped location offset value)
            value))))))
+
+#+cmu
+(defmacro with-pinned-objects (objects &body body)
+  (declare (ignore objects))
+  `(without-gcing ,@body))
+