X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fobjects.lisp;h=33bd042e71048e36dec970f0c78e20a58f5f2386;hb=cdf0c1b6baea88081a47b5e07320ba1ddb466e26;hp=6ec32234aaa87792332dc39ebc2bb0a4c65784ed;hpb=868ae7fad94b80592524dea37eae1000075605c6;p=uffi.git diff --git a/src/objects.lisp b/src/objects.lisp index 6ec3223..33bd042 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -9,30 +9,27 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg ;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* (in-package #:uffi) -(defun size-of-foreign-type (type) - #+lispworks (fli:size-of type) - #+allegro (ff:sizeof-fobject type) - #+(or cmu scl) (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes - #+sbcl (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes - #+clisp (values (ffi:size-of type)) - #+(and mcl (not openmcl)) - (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 - #+openmcl (ccl::%foreign-type-or-record-size type :bytes) - ) - - +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun size-of-foreign-type (type) + #+lispworks (fli:size-of type) + #+allegro (ff:sizeof-fobject type) + #+(or cmu scl) (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes + #+sbcl (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes + #+clisp (values (ffi:size-of type)) + #+(and mcl (not openmcl)) + (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 + #+openmcl (ccl::%foreign-type-or-record-size type :bytes) + )) + (defmacro allocate-foreign-object (type &optional (size :unspecified)) "Allocates an instance of TYPE. If size is specified, then allocate an array of TYPE with size SIZE. The TYPE parameter is evaluated." @@ -51,21 +48,9 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ) (progn #+(or cmu scl) - (if (integerp size) - `(alien:cast - (alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) - (array ,(convert-from-uffi-type (eval type) :allocation) ,size)) - `(alien:cast - (alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) - (array ,(convert-from-uffi-type (eval type) :allocation) nil))) + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) #+sbcl - (if (integerp size) - `(sb-alien:cast - (sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) - (array ,(convert-from-uffi-type (eval type) :allocation) ,size)) - `(sb-alien:cast - (sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) - (array ,(convert-from-uffi-type (eval type) :allocation) nil))) + `(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 @@ -133,24 +118,25 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ) -#+mcl +#+(and mcl (not openmcl)) (defmacro deref-pointer-set (ptr type value) `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) -#+mcl +#+(and mcl (not openmcl)) (defsetf deref-pointer deref-pointer-set) (defmacro ensure-char-character (obj) #+(or (and mcl (not openmcl))) obj #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj) ;; lispworks varies whether deref'ing array vs. slot access of a char - #+lispworks - `(if (characterp ,obj) ,obj (code-char ,obj))) + #+lispworks `(if (characterp ,obj) ,obj (code-char ,obj))) (defmacro ensure-char-integer (obj) #+(or (and mcl (not openmcl))) `(char-code ,obj) #+(or allegro cmu sbcl scl openmcl) obj - `(if (characterp ,obj) (char-code ,obj) ,obj)) + ;; lispworks varies whether deref'ing array vs. slot access of a char + #+lispworks + `(if (integerp ,obj) ,obj (char-code ,obj))) (defmacro ensure-char-storable (obj) #+(or lispworks (and mcl (not openmcl))) obj @@ -178,10 +164,15 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (progn ,@body) (free-foreign-object ,var))) #+(or cmu scl) - (let ((obj (gensym))) - `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate))) - (let ((,var (alien:addr ,obj))) - ,@body))) + (let ((obj (gensym)) + (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)))) #+sbcl (let ((obj (gensym)) (ctype (convert-from-uffi-type (eval type) :allocate))) @@ -245,12 +236,18 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(let ((,binding-name ,pointer)) ,@body)) -#-(or lispworks cmu scl sbcl allegro) +#-(or lispworks cmu scl sbcl allegro openmcl) (defmacro with-cast-pointer ((binding-name pointer type) &body body) - (declare (ignore binding-name pointer type)) + (declare (ignore binding-name pointer type body)) '(error "WITH-CAST-POINTER not (yet) implemented for ~A" (lisp-implementation-type))) +#+(or allegro openmcl) +(defun convert-external-name (name) + "Add an underscore to NAME if necessary for the ABI." + #+(or macosx darwinppc-target) (concatenate 'string "_" name) + #-(or macosx darwinppc-target) name) + (defmacro def-foreign-var (names type module) #-lispworks (declare (ignore module)) (let ((foreign-name (if (atom names) names (first names))) @@ -264,7 +261,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+allegro `(define-symbol-macro ,lisp-name (ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) - :c (ff:get-entry-point ,foreign-name))) + :c (ff:get-entry-point ,(convert-external-name foreign-name)))) #+lispworks `(progn (fli:define-foreign-variable (,lisp-name ,foreign-name) @@ -273,7 +270,11 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." :module ,module) (define-symbol-macro ,lisp-name (fli:dereference (,lisp-name) :copy-foreign-object nil))) - #-(or allegro cmu scl sbcl lispworks) + #+openmcl + `(define-symbol-macro ,lisp-name + (deref-pointer (ccl:foreign-symbol-address + ,(convert-external-name foreign-name)) ,var-type)) + #-(or allegro cmu scl sbcl lispworks openmcl) `(define-symbol-macro ,lisp-name '(error "DEF-FOREIGN-VAR not (yet) defined for ~A" (lisp-implementation-type)))))