;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: basic-types.lisp,v 1.9 2007-06-20 09:49:06 espen Exp $
+;; $Id: basic-types.lisp,v 1.10 2007-09-07 07:28:42 espen Exp $
(in-package "GFFI")
+(deftype byte () '(unsigned-byte 8))
(deftype int ()
'(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
#+clisp #.(ffi:bitsizeof 'ffi:int)
(deftype signed (&optional (size '*)) `(signed-byte ,size))
(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
(deftype char () 'base-char)
-(deftype pointer ()
- #+(or cmu sbcl) 'system-area-pointer
- #+clisp 'ffi:foreign-address)
(deftype pointer-data ()
'(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:system-area-pointer)
#+clisp #.(ffi:bitsizeof 'ffi:c-pointer)
(define-type-generic alien-type (type)
"Returns the foreign type corresponding to TYPE")
+(define-type-generic argument-type (type)
+ "Returns the type to be used in argument declarations for TYPE.")
+(define-type-generic return-type (type)
+ "Returns the type to be used in return type declarations for TYPE.")
(define-type-generic size-of (type &key inlined)
"Returns the foreign size of TYPE. The default value of INLINED is
T for basic C types and NIL for other types.")
(define-type-method alien-type ((type t))
(error "No alien type corresponding to the type specifier ~A" type))
+(define-type-method argument-type ((type t))
+ type)
+
+(define-type-method return-type ((type t))
+ type)
+
(define-type-method to-alien-form ((type t) form &optional copy-p)
(declare (ignore form copy-p))
(error "Not a valid type specifier for arguments: ~A" type))
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint8 offset)
- value)))
- (16 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint16 offset)
- value)))
- (32 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint32 offset)
- value)))
- (64 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(signed-sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint64 offset)
- value)))))))
+ ( 8 #'(setf ref-int-8))
+ (16 #'(setf ref-native-int-16))
+ (32 #'(setf ref-native-int-32))
+ (64 #'(setf ref-native-int-64))))))
(define-type-method reader-function ((type signed-byte) &key ref (inlined t))
(declare (ignore ref))
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint8 offset)))
- (16 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint16 offset)))
- (32 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint32 offset)))
- (64 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(signed-sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:sint64 offset)))))))
-
+ ( 8 #'ref-int-8)
+ (16 #'ref-native-int-16)
+ (32 #'ref-native-int-32)
+ (64 #'ref-native-int-64)))))
;;; Unsigned Byte
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint8 offset)
- value)))
- (16 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint16 offset)
- value)))
- (32 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint32 offset)
- value)))
- (64 #'(lambda (value location &optional (offset 0))
- (setf
- #+(or cmu sbcl)(sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint64 offset)
- value)))))))
+ ( 8 #'(setf ref-uint-8))
+ (16 #'(setf ref-native-uint-16))
+ (32 #'(setf ref-native-uint-32))
+ (64 #'(setf ref-native-uint-64))))))
(define-type-method reader-function ((type unsigned-byte) &key ref (inlined t))
(declare (ignore ref))
(second (type-expand-to 'signed-byte 'int))
size)))
(ecase size
- ( 8 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-8 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint8 offset)))
- (16 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-16 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint16 offset)))
- (32 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-32 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint32 offset)))
- (64 #'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(sap-ref-64 location offset)
- #+clisp(ffi:memory-as location 'ffi:uint64 offset)))))))
-
+ ( 8 #'ref-uint-8)
+ (16 #'ref-native-uint-16)
+ (32 #'ref-native-uint-32)
+ (64 #'ref-native-uint-64)))))
;;; Single Float
#+sbcl 'sb-alien:single-float
#+clisp 'single-float)
+(define-type-method argument-type ((type single-float))
+ (declare (ignore type))
+ 'number)
+
(define-type-method size-of ((type single-float) &key (inlined t))
(assert-inlined type inlined)
#+sbcl (sb-sizeof 'sb-alien:float)
(declare (ignore temp))
(assert-inlined type inlined)
#'(lambda (number location &optional (offset 0))
- (setf (ref-single-float location offset) (coerce number 'single-float))))
+ (setf (ref-native-single-float location offset) (coerce number 'single-float))))
(define-type-method reader-function ((type single-float) &key ref (inlined t))
(declare (ignore ref))
(assert-inlined type inlined)
- #'ref-single-float)
+ #'ref-native-single-float)
#+sbcl 'sb-alien:double-float
#+clisp 'double-float)
+(define-type-method argument-type ((type double-float))
+ (declare (ignore type))
+ 'number)
+
(define-type-method size-of ((type double-float) &key (inlined t))
(assert-inlined type inlined)
#+sbcl (sb-sizeof 'sb-alien:double)
(declare (ignore temp))
(assert-inlined type inlined)
#'(lambda (value location &optional (offset 0))
- (setf (ref-double-float location offset) (coerce value 'double-float))))
+ (setf (ref-native-double-float location offset) (coerce value 'double-float))))
(define-type-method reader-function ((type double-float) &key ref (inlined t))
(declare (ignore ref))
(assert-inlined type inlined)
- #'ref-double-float)
+ #'ref-native-double-float)
(deftype optimized-double-float () 'double-float)
(declare (ignore type copy-p))
form)
+(define-type-method argument-type ((type optimized-double-float))
+ (declare (ignore type))
+ 'double-float)
+
;;; Character
(declare (ignore temp))
(assert-inlined type inlined)
#'(lambda (char location &optional (offset 0))
- #+(or cmu sbcl)
- (setf (sap-ref-8 location offset) (char-code char))
- #+clisp(setf (ffi:memory-as location 'ffi:character offset) char)))
+ (setf (ref-int-8 location offset) (char-code char))))
(define-type-method reader-function ((type base-char) &key ref (inlined t))
(declare (ignore ref))
(assert-inlined type inlined)
#'(lambda (location &optional (offset 0))
- #+(or cmu sbcl)(code-char (sap-ref-8 location offset))
- #+clisp(ffi:memory-as location 'ffi:character offset)))
+ (code-char (ref-int-8 location offset))))
as char-code = (char-code char)
do (flet ((encode (size)
(let ((rem (mod size 6)))
- (setf (ref-byte location i)
+ (setf (ref-uint-8 location i)
(deposit-field
#xFF (byte (- 7 rem) (1+ rem))
(ldb (byte rem (- size rem)) char-code)))
(loop
for pos from (- size rem 6) downto 0 by 6
- do (setf (ref-byte location (incf i))
+ do (setf (ref-uint-8 location (incf i))
(+ 128 (ldb (byte 6 pos) char-code)))))))
(cond
- ((< char-code #x80) (setf (ref-byte location i) char-code))
+ ((< char-code #x80) (setf (ref-uint-8 location i) char-code))
((< char-code #x800) (encode 11))
((< char-code #x10000) (encode 16))
((< char-code #x200000) (encode 21)))))
- (setf (ref-byte location (1- len)) 0)
+ (setf (ref-uint-8 location (1- len)) 0)
location))
(defun decode-utf8-string (c-string)
(with-output-to-string (string)
(loop
for i from 0
- as octet = (ref-byte c-string i)
+ as octet = (ref-uint-8 c-string i)
until (zerop octet)
do (flet ((decode (size)
(loop
for pos from (- size rem) downto 0 by 6
as code = (dpb (ldb (byte rem 0) octet) (byte rem pos) 0)
then (dpb
- (ldb (byte 6 0) (ref-byte c-string (incf i)))
+ (ldb (byte 6 0) (ref-uint-8 c-string (incf i)))
(byte 6 pos) code)
finally (write-char (code-char code) string))))
(cond
(declare (ignore type))
(alien-type 'pointer))
+(define-type-method argument-type ((type string))
+ 'string)
+
+(define-type-method return-type ((type string))
+ 'string)
+
(define-type-method size-of ((type string) &key inlined)
(assert-not-inlined type inlined)
(size-of 'pointer))
(let* ((string (ref-pointer from offset))
(length (loop
for i from 0
- until (zerop (ref-byte string i))
+ until (zerop (ref-uint-8 string i))
finally (return (1+ i)))))
(setf (ref-pointer to offset) (copy-memory string length)))))
(declare (ignore type))
(alien-type 'string))
+(define-type-method argument-type ((type pathname))
+ (declare (ignore type))
+ '(or pathname string))
+
(define-type-method size-of ((type pathname) &key inlined)
(assert-not-inlined type inlined)
(size-of 'string))
(declare (ignore type))
(alien-type 'bool))
+(define-type-method argument-type ((type boolean))
+ (declare (ignore type))
+ t)
+
(define-type-method size-of ((type boolean) &key (inlined t))
(assert-inlined type inlined)
(size-of 'bool))
(error "No common alien type specifier for union type: ~A" type))
alien-type))
+(define-type-method argument-type ((type or))
+ (let ((expanded-type (type-expand-to 'or type)))
+ `(or ,@(mapcar #'argument-type (rest expanded-type)))))
+
+
(define-type-method size-of ((type or) &key (inlined nil inlined-p))
(loop
for subtype in (type-expand-to 'or type)
`(,type ,(alien-arg-wrapper type var value style form copy-in-p)))
(rest (type-expand-to 'or type)))))
((in-arg-p style)
- (let ((body (make-symbol "BODY")))
- `(flet ((,body (,var)
- ,form))
- (etypecase ,value
- ,@(mapcar
- #'(lambda (type)
- `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
- (rest (type-expand-to 'or type)))))))
+ ;; If the unexpanded type has explicit alien-type and
+ ;; to-alien-form methods, we just call the default arg wrapper
+ (if (and
+ (not (eq (first (mklist type)) 'or))
+ (find-type-method 'alien-type type nil)
+ (find-type-method 'to-alien-form type nil))
+ (funcall (find-type-method 'alien-arg-wrapper t) type var value style form copy-in-p)
+ (let ((body (make-symbol "BODY")))
+ `(flet ((,body (,var)
+ ,form))
+ (etypecase ,value
+ ,@(mapcar
+ #'(lambda (type)
+ `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
+ (rest (type-expand-to 'or type))))))))
((out-arg-p style)
#+(or cmu sbcl)
`(with-alien ((,var ,(alien-type type)))
;;; Copy-of
+(define-type-method return-type ((type copy-of))
+ (return-type (second type)))
+
(define-type-method from-alien-form ((type copy-of) form &key (ref :copy))
(if (eq ref :copy)
(from-alien-form (second (type-expand-to 'copy-of type)) form :ref ref)
;;; Static
+(define-type-method return-type ((type static))
+ (return-type (second type)))
+
(define-type-method from-alien-form ((type static) form &key (ref :static))
(if (eq ref :static)
(from-alien-form (second (type-expand-to 'static type)) form :ref ref)
(assert-inlined type inlined)
(size-of (second (type-expand-to 'inlined type)) :inlined t))
+(define-type-method return-type ((type inlined))
+ (return-type (second type)))
+
(define-type-method type-alignment ((type inlined) &key (inlined t))
(assert-inlined type inlined)
(type-alignment (second (type-expand-to 'inlined type)) :inlined t))
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: defpackage.lisp,v 1.11 2007-06-02 07:26:24 espen Exp $
+;; $Id: defpackage.lisp,v 1.12 2007-09-07 07:28:42 espen Exp $
(defpackage "GFFI"
(:use "COMMON-LISP" "AUTOEXPORT" "PKG-CONFIG" "CLG-UTILS")
"READER-FUNCTION" "WRITER-FUNCTION" "GETTER-FUNCTION"
"PEEK-FUNCTION" "DESTROY-FUNCTION" "UNBOUND-VALUE"
"COPY-FUNCTION" "ASSERT-INLINED" "ASSERT-NOT-INLINED"
- "UTF8-LENGTH" "OPTIMIZED-DOUBLE-FLOAT" "POINTER-DATA")
+ "UTF8-LENGTH" "OPTIMIZED-DOUBLE-FLOAT" "POINTER-DATA"
+ "ARGUMENT-TYPE" "RETURN-TYPE")
;; Symbols from vector.lisp
(:export "MAKE-C-VECTOR" "MAP-C-VECTOR" "WITH-C-VECTOR" "COUNTED-VECTOR"
- "NULL-TERMINATED-VECTOR")
+ "NULL-TERMINATED-VECTOR" "VECTOR-READER-FUNCTION"
+ "VECTOR-WRITER-FUNCTION" "VECTOR-REF-BYTE" "VECTOR-REF-INT-16"
+ "VECTOR-REF-UINT-16" "VECTOR-REF-INT-32" "VECTOR-REF-UINT-32"
+ "VECTOR-REF-INT-64" "VECTOR-REF-UINT-64" "VECTOR-REF-DOUBLE-FLOAT"
+ "VECTOR-REF-SINGLE-FLOAT")
;; Symbols from enums.lisp
(:export "ENUM" "ENUM-INT" "INT-ENUM" "ENUM-MAPPING" "DEFINE-ENUM-TYPE"
"FLAGS" "DEFINE-FLAGS-TYPE")
:depends-on (clg-tools)
:components ((:file "defpackage")
#+(and cmu19a (not non-broken-pcl))(:file "pcl")
+ (:unix-dso "alien" :components ((:c-source-file "memory")))
(:file "memory" :depends-on ("defpackage"))
(:file "interface" :depends-on ("memory"))
- (:file "basic-types" :depends-on ("interface"))
+ (:file "basic-types" :depends-on ("alien" "interface"))
(:file "vectors" :depends-on ("basic-types"))
(:file "enums" :depends-on ("basic-types"))
(:file "virtual-slots" :depends-on (#+(and cmu19a (not non-broken-pcl))"pcl" "interface" "basic-types"))
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: interface.lisp,v 1.5 2007-04-06 16:06:24 espen Exp $
+;; $Id: interface.lisp,v 1.6 2007-09-07 07:28:42 espen Exp $
(in-package "GFFI")
(let* ((lambda-list-supplied-p lambda-list)
(lambda-list (unless (equal lambda-list '(nil)) lambda-list))
- (aux-vars ())
+ (arg-types ())
+ (aux-bindings ())
(doc-string (when (stringp (first args)) (pop args)))
(parsed-args
(mapcar
#'(lambda (arg)
(destructuring-bind
- (expr type &optional (style :in) (out-type type)) arg
+ (expr type &optional (style :in) (out-type type))
+ (if (atom arg)
+ (list arg arg)
+ arg)
(cond
((find style '(:in-out :return))
(warn "Deprecated argument style: ~S" style))
(error "Bogus argument style: ~S" style)))
(when (and
(not lambda-list-supplied-p)
- (namep expr) (in-arg-p style))
- (push expr lambda-list))
+ (namep expr) (in-arg-p style)
+ (not (find expr lambda-list)))
+ (push expr lambda-list)
+ (push type arg-types))
(let ((aux (unless (or (not (in-arg-p style)) (namep expr))
(gensym))))
(when aux
- (push `(,aux ,expr) aux-vars))
+ (push (list aux expr) aux-bindings))
(list
(cond
((and (namep expr) (not (in-arg-p style))) expr)
(%defbinding c-name lisp-name
(if lambda-list-supplied-p lambda-list (nreverse lambda-list))
- aux-vars return-type doc-string parsed-args))))
+ (not lambda-list-supplied-p) (nreverse arg-types)
+ aux-bindings return-type doc-string parsed-args))))
#+(or cmu sbcl)
;; TODO: check if in and out types (if different) translates to same
;; alien type
-(defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args)
+(defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
(let ((out (loop
for (var expr type style out-type) in args
when (or (out-arg-p style) (return-arg-p style))
(alien-arg-wrapper type var expr style
(create-wrapper (rest args) body)))
body)))
- `(defun ,lisp-name ,lambda-list
+ `(progn
+ ,(when declare-p
+ `(declaim
+ (ftype
+ (function
+ ,(mapcar #'argument-type arg-types)
+ (values
+ ,@(when return-type (list (return-type return-type)))
+ ,@(loop
+ for (var expr type style out-type) in args
+ when (out-arg-p style)
+ collect (return-type out-type)
+ when (return-arg-p style)
+ collect (return-type type)))))))
+ (defun ,lisp-name ,lambda-list
,doc
- (let ,aux-vars
+ (let ,aux-bindings
,(if return-type
(create-wrapper args `(values ,fcall ,@out))
- (create-wrapper args `(progn ,fcall (values ,@out)))))))))
+ (create-wrapper args `(progn ,fcall (values ,@out))))))))))
;;;; Type methods
+(defun find-type-method (name type-spec &optional (error-p t))
+ (let ((type-methods (get name 'type-methods))
+ (specifier (if (atom type-spec)
+ type-spec
+ (first type-spec))))
+ (or
+ (gethash specifier type-methods)
+ (when error-p
+ (error
+ "No explicit type method for ~A when call width type specifier ~A found"
+ name type-spec)))))
+
(defun find-next-type-method (name type-spec &optional (error-p t))
(let ((type-methods (get name 'type-methods)))
(labels ((search-method-in-cpl-order (classes)
name type-spec))))))
(defun find-applicable-type-method (name type-spec &optional (error-p t))
- (let ((type-methods (get name 'type-methods))
- (specifier (if (atom type-spec)
- type-spec
- (first type-spec))))
- (or
- (gethash specifier type-methods)
- (find-next-type-method name type-spec nil)
- (when error-p
- (error
- "No applicable type method for ~A when call width type specifier ~A"
- name type-spec)))))
+ (or
+ (find-type-method name type-spec nil)
+ (find-next-type-method name type-spec nil)
+ (when error-p
+ (error
+ "No applicable type method for ~A when call width type specifier ~A"
+ name type-spec))))
+
(defun insert-type-in-hierarchy (specifier function nodes)
(cond
;; 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.4 2007-06-02 07:26:23 espen Exp $
+;; $Id: memory.lisp,v 1.5 2007-09-07 07:28:42 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))
-(defun ref-int-32 (location &optional (offset 0))
+
+(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:int16 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:int16 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))
-(defun (setf ref-int-32) (value location &optional (offset 0))
+(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))
-(defun ref-uint-32 (location &optional (offset 0))
+(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))
-(defun (setf ref-uint-32) (value location &optional (offset 0))
+(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))
-(defun ref-single-float (location &optional (offset 0))
+
+(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))
-(defun (setf ref-single-float) (value location &optional (offset 0))
+(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))
-(defun ref-double-float (location &optional (offset 0))
+(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))
-(defun (setf ref-double-float) (value location &optional (offset 0))
+(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))
-
(defparameter *memory-allocator* nil)
(defparameter *memory-deallocator* nil)
(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)
(if *memory-deallocator*
#-(or cmu sbcl)
(loop
for offset below length
- do (setf (ref-byte to offset) (ref-byte from offset)))
+ do (setf (ref-uint-88 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)
(/ (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))))))
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: vectors.lisp,v 1.4 2007-06-18 10:13:07 espen Exp $
+;; $Id: vectors.lisp,v 1.5 2007-09-07 07:28:42 espen Exp $
(in-package "GFFI")
+
+;;; Accessor functions for raw memory access
+
+(define-memory-accessor int-16)
+(define-memory-accessor int-32)
+(define-memory-accessor int-64)
+(define-memory-accessor uint-16)
+(define-memory-accessor uint-32)
+(define-memory-accessor uint-64)
+(define-memory-accessor single-float)
+(define-memory-accessor double-float)
+
+
;;; Vector
(defun make-c-vector (type length &key content location temp)
(declare (ignore type))
(alien-type 'pointer))
+(defun vector-type (type)
+ (destructuring-bind (element-type &optional (length '*))
+ (rest (type-expand-to 'vector type))
+ (if (constantp length)
+ `(vector ,(return-type element-type) ,length)
+ `(vector ,(return-type element-type) *))))
+
+(define-type-method argument-type ((type vector))
+ (vector-type type))
+
+(define-type-method return-type ((type vector))
+ (vector-type type))
+
(define-type-method size-of ((type vector) &key inlined)
(if inlined
(destructuring-bind (element-type &optional (length '*))
repeat length
for element from counter-size by element-size
do (funcall copy-element from-vector to-vector element))))))))
+
+
+;;;; Accessor functions for raw memory access
+
+(defun vector-reader-function (type &key (start 0) end)
+ "Returns a function for reading values from raw C vectors"
+ (let ((element-size (size-of type))
+ (reader (reader-function type)))
+ #'(lambda (vector index)
+ (assert (and (>= index start) (or (not end) (< index end))))
+ (funcall reader vector (* index element-size)))))
+
+(defun vector-writer-function (type &key (start 0) end)
+ "Returns a function for writing values to raw C vectors"
+ (let ((element-size (size-of type))
+ (writer (writer-function type)))
+ #'(lambda (value vector index)
+ (assert (and (>= index start) (or (not end) (< index end))))
+ (funcall writer value vector (* index element-size)))))
+
+
+(defmacro define-vector-accessor (type)
+ (let ((name (intern (format nil "VECTOR-REF-~A" type)))
+ (ref (intern (format nil "REF-~A" type))))
+ `(progn
+ (declaim
+ (ftype (function (pointer fixnum) ,type) ,name)
+ (inline ,name))
+ (defun ,name (vector index)
+ (,ref vector (* ,(size-of type) index)))
+ (declaim
+ (ftype (function (,type pointer fixnum) ,type) (setf ,name))
+ (inline (setf ,name)))
+ (defun (setf ,name) (value vector index)
+ (setf (,ref vector (* ,(size-of type) index)) value)))))
+
+(define-vector-accessor int-8)
+(define-vector-accessor uint-8)
+(define-vector-accessor int-16)
+(define-vector-accessor uint-16)
+(define-vector-accessor int-32)
+(define-vector-accessor uint-32)
+(define-vector-accessor int-64)
+(define-vector-accessor uint-64)
+(define-vector-accessor double-float)
+(define-vector-accessor single-float)
+
~mdw / clg / commitdiff