X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/beae657932a8db54ea662b6b48eebb62dd23f98b..c470da880479bee6a13115ccb70d62cdcf6f532c:/gffi/basic-types.lisp diff --git a/gffi/basic-types.lisp b/gffi/basic-types.lisp index b355f5e..e5582db 100644 --- a/gffi/basic-types.lisp +++ b/gffi/basic-types.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: basic-types.lisp,v 1.1 2006-04-25 20:36:05 espen Exp $ +;; $Id: basic-types.lisp,v 1.9 2007-06-20 09:49:06 espen Exp $ (in-package "GFFI") @@ -55,6 +55,11 @@ (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) + #-(or sbcl clisp) 32)) + (deftype bool (&optional (size '*)) (declare (ignore size)) 'boolean) (deftype copy-of (type) type) (deftype static (type) type) @@ -67,6 +72,9 @@ (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-generic type-alignment (type &key inlined) + "Returns the alignment of TYPE. The default value of INLINED is +T for basic C types and NIL for other types.") (define-type-generic alien-arg-wrapper (type var arg style form &optional copy-p) "Creates a wrapper around FORM which binds the alien translation of ARG to VAR in a way which makes it possible to pass the location of @@ -202,6 +210,10 @@ have been written as temporal.") (declare (ignore type)) (size-of 'signed-byte :inlined inlined)) +(define-type-method type-alignment ((type integer) &key (inlined t)) + (declare (ignore type)) + (type-alignment 'signed-byte :inlined inlined)) + (define-type-method writer-function ((type integer) &key temp (inlined t)) (declare (ignore temp)) (assert-inlined type inlined) @@ -253,6 +265,21 @@ have been written as temporal.") (32 4) (64 8))))) +(define-type-method type-alignment ((type signed-byte) &key (inlined t)) + (assert-inlined type inlined) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'signed-byte type))) + (let ((size (if (eq size '*) + (second (type-expand-to 'signed-byte 'int)) + size))) + #+sbcl(sb-alignment `(sb-alien:signed ,size)) + #+clisp(ecase size + ( 8 (nth-value 1 (ffi:sizeof 'ffi:sint8))) + (16 (nth-value 1 (ffi:sizeof 'ffi:sint16))) + (32 (nth-value 1 (ffi:sizeof 'ffi:sint32))) + (64 (nth-value 1 (ffi:sizeof 'ffi:sint64)))) + #-(or sbcl clisp) 4))) + (define-type-method writer-function ((type signed-byte) &key temp (inlined t)) (declare (ignore temp)) (assert-inlined type inlined) @@ -340,6 +367,12 @@ have been written as temporal.") (rest (mklist (type-expand-to 'unsigned-byte type))) (size-of `(signed ,size)))) +(define-type-method type-alignment ((type unsigned-byte) &key (inlined t)) + (assert-inlined type inlined) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'unsigned-byte type))) + (type-alignment `(signed ,size)))) + (define-type-method writer-function ((type unsigned-byte) &key temp (inlined t)) (declare (ignore temp)) (assert-inlined type inlined) @@ -408,6 +441,12 @@ have been written as temporal.") #+clisp (ffi:sizeof 'single-float) #-(or sbcl clisp) 4) +(define-type-method type-alignment ((type single-float) &key (inlined t)) + (assert-inlined type inlined) + #+sbcl (sb-alignment 'single-float) + #+clisp (nth-value 1 (ffi:sizeof 'single-float)) + #-(or sbcl clisp) 4) + (define-type-method to-alien-form ((type single-float) form &optional copy-p) (declare (ignore type copy-p)) `(coerce ,form 'single-float)) @@ -420,18 +459,13 @@ have been written as temporal.") (define-type-method writer-function ((type single-float) &key temp (inlined t)) (declare (ignore temp)) (assert-inlined type inlined) - #'(lambda (value location &optional (offset 0)) - (setf - #+(or cmu sbcl)(sap-ref-single location offset) - #+clisp(ffi:memory-as location 'single-float offset) - (coerce value 'single-float)))) + #'(lambda (number location &optional (offset 0)) + (setf (ref-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) - #'(lambda (location &optional (offset 0)) - #+(or cmu sbcl)(sap-ref-single location offset) - #+clisp(ffi:memory-as location 'single-float offset))) + #'ref-single-float) @@ -449,6 +483,12 @@ have been written as temporal.") #+clisp (ffi:sizeof 'double-float) #-(or sbcl clisp) 8) +(define-type-method type-alignment ((type double-float) &key (inlined t)) + (assert-inlined type inlined) + #+sbcl (sb-alignment 'double-float) + #+clisp (nth-value 1 (ffi:sizeof 'double-float)) + #-(or sbcl clisp) 4) + (define-type-method to-alien-form ((type double-float) form &optional copy-p) (declare (ignore type copy-p)) `(coerce ,form 'double-float)) @@ -462,17 +502,18 @@ have been written as temporal.") (declare (ignore temp)) (assert-inlined type inlined) #'(lambda (value location &optional (offset 0)) - (setf - #+(or cmu sbcl)(sap-ref-double location offset) - #+clisp(ffi:memory-as location 'double-float offset) - (coerce value 'double-float)))) + (setf (ref-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) - #'(lambda (location &optional (offset 0)) - #+(or cmu sbcl)(sap-ref-double location offset) - #+clisp(ffi:memory-as location 'double-float offset))) + #'ref-double-float) + +(deftype optimized-double-float () 'double-float) + +(define-type-method to-alien-form ((type optimized-double-float) form &optional copy-p) + (declare (ignore type copy-p)) + form) @@ -487,6 +528,12 @@ have been written as temporal.") (define-type-method size-of ((type base-char) &key (inlined t)) (assert-inlined type inlined) 1) + +(define-type-method type-alignment ((type base-char) &key (inlined t)) + (assert-inlined type inlined) + #+sbcl (sb-alignment 'sb-alien:char) + #+clisp (nth-value 1 (ffi:sizeof 'ffi:character)) + #-(or sbcl clisp) 4) (define-type-method to-alien-form ((type base-char) form &optional copy-p) (declare (ignore type copy-p)) @@ -524,6 +571,7 @@ have been written as temporal.") ;;; String (defun utf8-length (string) + "Returns the length including the trailing zero, of STRING encoded as UTF8" (1+ (loop for char across string as char-code = (char-code char) @@ -534,7 +582,8 @@ have been written as temporal.") ((< char-code #x1FFFFF) 4))))) (defun encode-utf8-string (string &optional location) - (let ((location (or location (allocate-memory (utf8-length string))))) + (let* ((len (utf8-length string)) + (location (or location (allocate-memory len)))) (loop for char across string for i from 0 @@ -553,8 +602,8 @@ have been written as temporal.") ((< char-code #x80) (setf (ref-byte location i) char-code)) ((< char-code #x800) (encode 11)) ((< char-code #x10000) (encode 16)) - ((< char-code #x200000) (encode 21)))) - finally (setf (ref-byte location (1+ i)) 0)) + ((< char-code #x200000) (encode 21))))) + (setf (ref-byte location (1- len)) 0) location)) (defun decode-utf8-string (c-string) @@ -607,6 +656,10 @@ have been written as temporal.") (assert-not-inlined type inlined) (size-of 'pointer)) +(define-type-method type-alignment ((type string) &key inlined) + (assert-not-inlined type inlined) + (type-alignment 'pointer)) + (define-type-method to-alien-form ((type string) string &optional copy-p) (declare (ignore type copy-p)) `(encode-utf8-string ,string)) @@ -697,6 +750,10 @@ have been written as temporal.") (assert-not-inlined type inlined) (size-of 'string)) +(define-type-method type-alignment ((type pathname) &key inlined) + (assert-not-inlined type inlined) + (type-alignment 'string)) + (define-type-method alien-arg-wrapper ((type pathname) var pathname style form &optional copy-in-p) (declare (ignore type)) (alien-arg-wrapper 'string var `(namestring (translate-logical-pathname ,pathname)) style form copy-in-p)) @@ -765,6 +822,12 @@ have been written as temporal.") (rest (mklist (type-expand-to 'bool type))) (size-of `(signed-byte ,size)))) +(define-type-method type-alignment ((type bool) &key (inlined t)) + (assert-inlined type inlined) + (destructuring-bind (&optional (size '*)) + (rest (mklist (type-expand-to 'bool type))) + (type-alignment `(signed-byte ,size)))) + (define-type-method to-alien-form ((type bool) bool &optional copy-p) (declare (ignore type copy-p)) `(if ,bool 1 0)) @@ -813,6 +876,10 @@ have been written as temporal.") (assert-inlined type inlined) (size-of 'bool)) +(define-type-method type-alignment ((type boolean) &key (inlined t)) + (assert-inlined type inlined) + (type-alignment 'bool)) + (define-type-method to-alien-form ((type boolean) boolean &optional copy-p) (declare (ignore type copy-p)) (to-alien-form 'bool boolean)) @@ -858,6 +925,13 @@ have been written as temporal.") (size-of subtype inlined) (size-of subtype)))) +(define-type-method type-alignment ((type or) &key (inlined nil inlined-p)) + (loop + for subtype in (type-expand-to 'or type) + maximize (if inlined-p + (type-alignment subtype inlined) + (type-alignment subtype)))) + (define-type-method alien-arg-wrapper ((type or) var value style form &optional copy-in-p) (cond ((and (in-arg-p style) (out-arg-p style)) @@ -919,6 +993,12 @@ have been written as temporal.") #+clisp (ffi:sizeof 'ffi:c-pointer) #-(or sbcl clisp) 4) +(define-type-method type-alignment ((type pointer) &key (inlined t)) + (assert-inlined type inlined) + #+sbcl (sb-alignment 'system-area-pointer) + #+clisp (ffi:sizeof 'ffi:c-pointer) + #-(or sbcl clisp) (size-of 'pointer)) + (define-type-method to-alien-form ((type pointer) form &optional copy-p) (declare (ignore type copy-p)) form) @@ -1008,7 +1088,7 @@ have been written as temporal.") (define-type-method from-alien-function ((type copy-of) &key (ref :copy)) (if (eq ref :copy) (from-alien-function (second (type-expand-to 'copy-of type)) :ref ref) - (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref))) + (error "Keyword arg :REF to FROM-ALIEN-FUNCTION should be :COPY for type ~A. It was give ~A" type ref))) (define-type-method to-alien-form ((type copy-of) form &optional (copy-p t)) (if copy-p @@ -1051,17 +1131,17 @@ have been written as temporal.") (define-type-method from-alien-function ((type static) &key (ref :static)) (if (eq ref :static) (from-alien-function (second (type-expand-to 'static type)) :ref ref) - (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref))) + (error "Keyword arg :REF to FROM-ALIEN-FUNCTION should be :STATIC for type ~A. It was give ~A" type ref))) (define-type-method to-alien-function ((type static) &optional copy-p) (if (not copy-p) (to-alien-function (second (type-expand-to 'static type)) t) - (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type))) + (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type))) (define-type-method to-alien-form ((type static) &optional copy-p) (if (not copy-p) - (to-alien-function (second (type-expand-to 'static type)) t) - (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type))) + (to-alien-form (second (type-expand-to 'static type)) t) + (error "COPY-P argument to TO-ALIEN-FORM should always be NIL for type ~A" type))) (define-type-method reader-function ((type static) &key (ref :read) (inlined nil inlined-p)) (if inlined-p @@ -1094,6 +1174,10 @@ have been written as temporal.") (assert-inlined type inlined) (size-of (second (type-expand-to 'inlined type)) :inlined t)) +(define-type-method type-alignment ((type inlined) &key (inlined t)) + (assert-inlined type inlined) + (type-alignment (second (type-expand-to 'inlined type)) :inlined t)) + (define-type-method reader-function ((type inlined) &key (ref :read) (inlined t)) (assert-inlined type inlined) (reader-function (second (type-expand-to 'inlined type)) :ref ref :inlined t))