From 2c708568813055419a75f313819c8b3e94f32932 Mon Sep 17 00:00:00 2001 Message-Id: <2c708568813055419a75f313819c8b3e94f32932.1714455839.git.mdw@distorted.org.uk> From: Mark Wooding Date: Fri, 7 Sep 2007 07:28:42 +0000 Subject: [PATCH] Added automatic function type declarations and accessor functions for raw memory vectors Organization: Straylight/Edgeware From: espen --- gffi/basic-types.lisp | 190 ++++++++++++++++++------------------- gffi/defpackage.lisp | 11 ++- gffi/gffi.asd | 3 +- gffi/interface.lisp | 74 ++++++++++----- gffi/memory.lisp | 213 +++++++++++++++++++++++++++++++++++++++--- gffi/vectors.lisp | 75 ++++++++++++++- 6 files changed, 430 insertions(+), 136 deletions(-) diff --git a/gffi/basic-types.lisp b/gffi/basic-types.lisp index e5582db..14cf78a 100644 --- a/gffi/basic-types.lisp +++ b/gffi/basic-types.lisp @@ -20,11 +20,12 @@ ;; 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) @@ -52,9 +53,6 @@ (deftype unsigned-short () (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) @@ -69,6 +67,10 @@ (deftype inlined (type) type) (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.") @@ -154,6 +156,12 @@ (define-type-method callback-wrapper ((type t) var arg form) (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)) @@ -289,26 +297,10 @@ (define-type-method writer-function ((type signed-byte) &key temp (inlined t)) (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)) @@ -319,19 +311,10 @@ (define-type-method reader-function ((type signed-byte) &key ref (inlined t)) (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 @@ -382,26 +365,10 @@ (define-type-method writer-function ((type unsigned-byte) &key temp (inlined t)) (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)) @@ -412,19 +379,10 @@ (define-type-method reader-function ((type unsigned-byte) &key ref (inlined t)) (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 @@ -435,6 +393,10 @@ (define-type-method alien-type ((type 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) @@ -460,12 +422,12 @@ (define-type-method writer-function ((type single-float) &key temp (inlined t)) (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) @@ -477,6 +439,10 @@ (define-type-method alien-type ((type double-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) @@ -502,12 +468,12 @@ (define-type-method writer-function ((type double-float) &key temp (inlined t)) (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) @@ -515,6 +481,10 @@ (define-type-method to-alien-form ((type optimized-double-float) form &optional (declare (ignore type copy-p)) form) +(define-type-method argument-type ((type optimized-double-float)) + (declare (ignore type)) + 'double-float) + ;;; Character @@ -555,16 +525,13 @@ (define-type-method writer-function ((type base-char) &key temp (inlined t)) (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)))) @@ -590,27 +557,27 @@ (defun encode-utf8-string (string &optional location) 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 @@ -618,7 +585,7 @@ (defun decode-utf8-string (c-string) 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 @@ -652,6 +619,12 @@ (define-type-method alien-type ((type string)) (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)) @@ -730,7 +703,7 @@ (define-type-method copy-function ((type string) &key inlined) (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))))) @@ -746,6 +719,10 @@ (define-type-method alien-type ((type pathname)) (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)) @@ -872,6 +849,10 @@ (define-type-method alien-type ((type boolean)) (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)) @@ -918,6 +899,11 @@ (define-type-method alien-type ((type or)) (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) @@ -941,14 +927,21 @@ (define-type-method alien-arg-wrapper ((type or) var value style form &optional `(,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))) @@ -1080,6 +1073,9 @@ (define-type-method to-alien-form ((type callback) callback &optional copy-p) ;;; 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) @@ -1123,6 +1119,9 @@ (define-type-method copy-function ((type copy-of) &key (inlined nil inlined-p)) ;;; 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) @@ -1174,6 +1173,9 @@ (define-type-method size-of ((type inlined) &key (inlined t)) (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)) diff --git a/gffi/defpackage.lisp b/gffi/defpackage.lisp index 578e8ca..082ebcc 100644 --- a/gffi/defpackage.lisp +++ b/gffi/defpackage.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: 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") @@ -66,10 +66,15 @@ (defpackage "GFFI" "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") diff --git a/gffi/gffi.asd b/gffi/gffi.asd index 4083f0d..72a5559 100644 --- a/gffi/gffi.asd +++ b/gffi/gffi.asd @@ -29,9 +29,10 @@ :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")) diff --git a/gffi/interface.lisp b/gffi/interface.lisp index 6778ea6..bcb0cae 100644 --- a/gffi/interface.lisp +++ b/gffi/interface.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: 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") @@ -99,13 +99,17 @@ (defmacro defbinding (name lambda-list return-type &rest args) (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)) @@ -113,12 +117,14 @@ (defmacro defbinding (name lambda-list return-type &rest args) (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) @@ -129,7 +135,8 @@ (defmacro defbinding (name lambda-list return-type &rest args) (%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) @@ -174,7 +181,7 @@ (defun foreign-funcall (cname args return-type) ;; 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)) @@ -189,12 +196,26 @@ (defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args) (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)))))))))) @@ -414,6 +435,18 @@ (defun type-expand-to (type form) ;;;; 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) @@ -463,17 +496,14 @@ (defun find-next-type-method (name type-spec &optional (error-p t)) 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 diff --git a/gffi/memory.lisp b/gffi/memory.lisp index 3712048..c58b37a 100644 --- a/gffi/memory.lisp +++ b/gffi/memory.lisp @@ -20,11 +20,14 @@ ;; 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) @@ -61,58 +64,200 @@ (defun (setf ref-pointer) (pointer location &optional (offset 0)) #+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) @@ -120,7 +265,6 @@ (defun allocate-memory (size) (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* @@ -133,7 +277,7 @@ (defun copy-memory (from length &optional (to (allocate-memory length))) #-(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)) @@ -142,13 +286,13 @@ (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) @@ -194,3 +338,42 @@ (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)))))) diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp index 0f85228..2131a2a 100644 --- a/gffi/vectors.lisp +++ b/gffi/vectors.lisp @@ -20,11 +20,24 @@ ;; 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) @@ -101,6 +114,19 @@ (define-type-method alien-type ((type vector)) (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 '*)) @@ -575,3 +601,50 @@ (define-type-method copy-function ((type counted-vector) &key inlined) 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]