;; 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.8 2008-04-29 22:11:35 espen Exp $
(in-package "GFFI")
+(deftype pointer ()
+ #+(or cmu sbcl) 'system-area-pointer
+ #+clisp 'ffi:foreign-address)
(defun make-pointer (address)
#+(or cmu sbcl)(int-sap address)
#+clisp(ffi:memory-as location 'ffi:c-pointer offset)
pointer))
+
+(deftype int-8 () '(signed-byte 8))
+(deftype uint-8 () '(unsigned-byte 8))
+(deftype int-16 () '(signed-byte 16))
+(deftype uint-16 () '(unsigned-byte 16))
+(deftype int-32 () '(signed-byte 32))
+(deftype uint-32 () '(unsigned-byte 32))
+(deftype int-64 () '(signed-byte 64))
+(deftype uint-64 () '(unsigned-byte 64))
+
+(declaim
+ (ftype (function (pointer &optional fixnum) int-8) ref-int-8)
+ (inline ref-int-8))
+(defun ref-int-8 (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-8 location offset)
+ #+clisp(ffi:memory-as location 'ffi:char offset))
+
+(declaim
+ (ftype (function (int-8 pointer &optional fixnum) int-8) (setf ref-int-8))
+ (inline (setf ref-int-8)))
+(defun (setf ref-int-8) (byte location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-8 location offset)
+ #+clisp(ffi:memory-as location 'ffi:char offset)
+ byte))
+
+;; Deprecated functions
(defun ref-byte (location &optional (offset 0))
+ (ref-int-8 location offset))
+(defun (setf ref-byte) (byte location &optional (offset 0))
+ (setf (ref-int-8 location offset) byte))
+
+
+(declaim
+ (ftype (function (pointer &optional fixnum) uint-8) ref-uint-8)
+ (inline ref-uint-8))
+(defun ref-uint-8 (location &optional (offset 0))
#+(or cmu sbcl)(sap-ref-8 location offset)
#+clisp(ffi:memory-as location 'ffi:uchar offset))
-(defun (setf ref-byte) (byte location &optional (offset 0))
+(declaim
+ (ftype (function (uint-8 pointer &optional fixnum) uint-8) (setf ref-uint-8))
+ (inline (setf ref-uint-8)))
+(defun (setf ref-uint-8) (byte location &optional (offset 0))
(setf
#+(or cmu sbcl)(sap-ref-8 location offset)
#+clisp(ffi:memory-as location 'ffi:uchar offset)
byte))
+
+(declaim
+ (ftype (function (pointer &optional fixnum) int-16) ref-native-int-16)
+ (inline ref-native-int-16))
+(defun ref-native-int-16 (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-16 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint16 offset))
+
+(declaim
+ (ftype
+ (function (uint-16 pointer &optional fixnum) int-16)
+ (setf ref-native-int-16))
+ (inline (setf ref-native-int-16)))
+(defun (setf ref-native-int-16) (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-16 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint16 offset)
+ value))
+
+(declaim
+ (ftype (function (pointer &optional fixnum) uint-16) ref-native-uint-16)
+ (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:uint16 offset))
+
+(declaim
+ (ftype
+ (function (uint-16 pointer &optional fixnum) uint-16)
+ (setf ref-native-uint-16))
+ (inline (setf ref-native-uint-16)))
+(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:uint16 offset)
+ value))
+
+
+(declaim
+ (ftype (function (pointer &optional fixnum) int-32) ref-native-int-32)
+ (inline ref-native-int-32))
+(defun ref-native-int-32 (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-32 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint32 offset))
+
+(declaim
+ (ftype (function (int-32 pointer &optional fixnum) int-32) (setf ref-native-int-32))
+ (inline (setf ref-native-int-32)))
+(defun (setf ref-native-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))
+
+(declaim
+ (ftype (function (pointer &optional fixnum) uint-32) ref-native-uint-32)
+ (inline ref-native-uint-32))
+(defun ref-native-uint-32 (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-32 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint32 offset))
+
+(declaim
+ (ftype
+ (function (uint-32 pointer &optional fixnum) uint-32)
+ (setf ref-native-uint-32))
+ (inline (setf ref-native-uint-32)))
+(defun (setf ref-native-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))
+
+
+(declaim
+ (ftype (function (pointer &optional fixnum) int-64) ref-native-int-64)
+ (inline ref-native-int-64))
+(defun ref-native-int-64 (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint64 offset))
+
+(declaim
+ (ftype (function (int-64 pointer &optional fixnum) int-64) (setf ref-native-int-64))
+ (inline (setf ref-native-int-64)))
+(defun (setf ref-native-int-64) (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint64 offset)
+ value))
+
+(declaim
+ (ftype (function (pointer &optional fixnum) uint-64) ref-native-uint-64)
+ (inline ref-native-uint-64))
+(defun ref-native-uint-64 (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint64 offset))
+
+(declaim
+ (ftype
+ (function (uint-64 pointer &optional fixnum) uint-64)
+ (setf ref-native-uint-64))
+ (inline (setf ref-native-uint-64)))
+(defun (setf ref-native-uint-64) (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint64 offset)
+ value))
+
+
+(declaim
+ (ftype (function (pointer &optional fixnum) single-float) ref-native-single-float)
+ (inline ref-native-single-float))
+(defun ref-native-single-float (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-single location offset)
+ #+clisp(ffi:memory-as location 'single-float offset))
+
+(declaim
+ (ftype
+ (function (single-float pointer &optional fixnum) single-float)
+ (setf ref-native-single-float))
+ (inline (setf ref-native-single-float)))
+(defun (setf ref-native-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))
+
+(declaim
+ (ftype (function (pointer &optional fixnum) double-float) ref-native-double-float)
+ (inline ref-native-double-float))
+(defun ref-native-double-float (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-double location offset)
+ #+clisp(ffi:memory-as location 'double-float offset))
+
+(declaim
+ (ftype
+ (function (double-float pointer &optional fixnum) double-float)
+ (setf ref-native-double-float))
+ (inline (setf ref-native-double-float)))
+(defun (setf ref-native-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))
+
+
+(defvar *memory-allocator* nil)
+(defvar *memory-deallocator* nil)
+
(defun allocate-memory (size)
- (declare (ignore size))
- (error "Memory allocator not set"))
-(declaim (ftype (function (integer) system-area-pointer) allocate-memory))
+ (if *memory-allocator*
+ (funcall *memory-allocator* size)
+ (error "Memory allocator not set")))
(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))
#-(or cmu sbcl)
(loop
for offset below length
- do (setf (ref-byte to offset) (ref-byte from offset)))
+ do (setf (ref-uint-8 to offset) (ref-uint-8 from offset)))
to)
(defun clear-memory (from length &optional (offset 0))
(loop
repeat length
for byte-offset from offset
- do (setf (ref-byte from byte-offset) 0)))
+ do (setf (ref-uint-8 from byte-offset) 0)))
(defun memory-clear-p (from length &optional (offset 0))
(loop
repeat length
for byte-offset from offset
- unless (zerop (ref-byte from byte-offset))
+ unless (zerop (ref-uint-8 from byte-offset))
do (return-from memory-clear-p nil))
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."
(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)))
+
+
+(deftype endian () '(member :native :little :big))
+
+(defmacro define-memory-accessor (type)
+ (let* ((get-swapped (intern (format nil "GET-~A-SWAPPED" type)))
+ (set-swapped (intern (format nil "SET-~A-SWAPPED" type)))
+ (ref (intern (format nil "REF-~A" type)))
+ (ref-native (intern (format nil "REF-NATIVE-~A" type))))
+ `(progn
+ (declaim (inline ,get-swapped) (inline ,set-swapped))
+ (defbinding ,get-swapped () ,type
+ (location pointer)
+ (offset int))
+ (defbinding ,set-swapped () nil
+ (location pointer)
+ (offset int)
+ (value ,type))
+ (declaim
+ (ftype (function (pointer &optional fixnum endian) ,type) ,ref)
+ (inline ,ref))
+ (defun ,ref (location &optional offset (endian :native))
+ (ecase endian
+ ((:native #-big-endian :little #+big-endian :big)
+ (,ref-native location offset))
+ ((#-big-endian :big #+big-endian :little)
+ (,get-swapped location offset))))
+ (declaim
+ (ftype
+ (function (,type pointer &optional fixnum endian) ,type)
+ (setf ,ref))
+ (inline (setf ,ref)))
+ (defun (setf ,ref) (value location &optional offset (endian :native))
+ (ecase endian
+ ((:native #-big-endian :little #+big-endian :big)
+ (setf (,ref-native location offset) value))
+ ((#-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))
+
~mdw / clg / blobdiff