X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=src%2Fobjects.lisp;h=c9935b755dfa64867a27e4c6c1e155264b67daa0;hb=b86fdf882156aa45dc6e8e93a158dedf506f4233;hp=67c9bcbee0092a814c73a9ccabf24d5553f909ea;hpb=cc7b3da48f78a00cf62737f447ef9fe05a79bc37;p=uffi.git diff --git a/src/objects.lisp b/src/objects.lisp index 67c9bcb..c9935b7 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -7,9 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id$ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* @@ -25,8 +23,8 @@ #+digitool (let ((mcl-type (ccl:find-mactype type nil t))) (if mcl-type - (ccl::mactype-record-size mcl-type) - (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record + (ccl::mactype-record-size mcl-type) + (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record #+openmcl (ccl::%foreign-type-or-record-size type :bytes) )) @@ -35,29 +33,29 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (if (eq size :unspecified) (progn - #+(or cmu scl) - `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) - #+sbcl - `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) - #+lispworks - `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate)) - #+allegro - `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c) - #+(or openmcl digitool) - `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) - ) + #+(or cmu scl) + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) + #+sbcl + `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) + #+lispworks + `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate)) + #+allegro + `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c) + #+(or openmcl digitool) + `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) + ) (progn - #+(or cmu scl) - `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) - #+sbcl - `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) - #+lispworks - `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size) - #+allegro - `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c) - #+(or openmcl digitool) - `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) - ))) + #+(or cmu scl) + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + #+sbcl + `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + #+lispworks + `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size) + #+allegro + `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c) + #+(or openmcl digitool) + `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) + ))) (defmacro free-foreign-object (obj) #+(or cmu scl) @@ -103,7 +101,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8))) #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8))) #+lispworks `(fli:make-pointer :type '(:unsigned :char) - :address (fli:pointer-address ,obj)) + :address (fli:pointer-address ,obj)) #+allegro obj #+(or openmcl digitool) obj ) @@ -139,8 +137,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(if (integerp ,obj) ,obj (char-code ,obj))) (defmacro ensure-char-storable (obj) - #+(or digitool (and lispworks (not lispworks5))) obj - #+(or allegro cmu lispworks5 openmcl sbcl scl) + #+(or digitool (and lispworks (not lispworks5) (not lispworks6))) obj + #+(or allegro cmu lispworks5 lispworks6 openmcl sbcl scl) `(char-code ,obj)) (defmacro pointer-address (obj) @@ -162,31 +160,31 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #-(or cmu sbcl lispworks scl) ; default version `(let ((,var (allocate-foreign-object ,type))) (unwind-protect - (progn ,@body) + (progn ,@body) (free-foreign-object ,var))) #+(or cmu scl) (let ((obj (gensym)) - (ctype (convert-from-uffi-type (eval type) :allocate))) + (ctype (convert-from-uffi-type (eval type) :allocate))) (if (and (consp ctype) (eq 'array (car ctype))) - `(alien:with-alien ((,obj ,ctype)) - (let* ((,var ,obj)) - ,@body)) - `(alien:with-alien ((,obj ,ctype)) - (let* ((,var (alien:addr ,obj))) - ,@body)))) + `(alien:with-alien ((,obj ,ctype)) + (let* ((,var ,obj)) + ,@body)) + `(alien:with-alien ((,obj ,ctype)) + (let* ((,var (alien:addr ,obj))) + ,@body)))) #+sbcl (let ((obj (gensym)) - (ctype (convert-from-uffi-type (eval type) :allocate))) + (ctype (convert-from-uffi-type (eval type) :allocate))) (if (and (consp ctype) (eq 'array (car ctype))) - `(sb-alien:with-alien ((,obj ,ctype)) - (let* ((,var ,obj)) - ,@body)) - `(sb-alien:with-alien ((,obj ,ctype)) - (let* ((,var (sb-alien:addr ,obj))) - ,@body)))) + `(sb-alien:with-alien ((,obj ,ctype)) + (let* ((,var ,obj)) + ,@body)) + `(sb-alien:with-alien ((,obj ,ctype)) + (let* ((,var (sb-alien:addr ,obj))) + ,@body)))) #+lispworks `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type - (eval type) :allocate))) + (eval type) :allocate))) ,@body) ) @@ -194,8 +192,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (defmacro with-foreign-objects (bindings &rest body) (if bindings `(with-foreign-object ,(car bindings) - (with-foreign-objects ,(cdr bindings) - ,@body)) + (with-foreign-objects ,(cdr bindings) + ,@body)) `(progn ,@body))) #+(or openmcl digitool)