X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fobjects.lisp;h=4930962437287a78af3c4233be16a14d83c7ea42;hb=c1f5fa10b352b00c916dcf388be5ad1f49240a2c;hp=19cb002d94ea50f698bbfa5db24ce9bc9504dab8;hpb=d2cba79718785eaf10ee11d661aca3f4ebb20929;p=uffi.git diff --git a/src/objects.lisp b/src/objects.lisp index 19cb002..4930962 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: objects.cl +;;;; Name: objects.lisp ;;;; Purpose: UFFI source to handle objects and pointers ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: objects.lisp,v 1.3 2002/10/14 07:08:49 kevin Exp $ +;;;; $Id: objects.lisp,v 1.15 2003/07/08 12:37:21 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,13 +16,12 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) +(in-package #:uffi) (defun size-of-foreign-type (type) #+lispworks (fli:size-of type) #+allegro (ff:sizeof-fobject type) - #+cmu (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes + #+(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)) @@ -39,32 +38,32 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (if (eq size :unspecified) (progn - #+cmu + #+(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) + `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c) #+mcl `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) ) (progn - #+cmu + #+(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 '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c) + `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c) #+mcl `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) ))) (defmacro free-foreign-object (obj) - #+cmu + #+(or cmu scl) `(alien:free-alien ,obj) #+sbcl `(sb-alien:free-alien ,obj) @@ -79,14 +78,14 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (defmacro null-pointer-p (obj) #+lispworks `(fli:null-pointer-p ,obj) #+allegro `(zerop ,obj) - #+cmu `(alien:null-alien ,obj) + #+(or cmu scl) `(alien:null-alien ,obj) #+sbcl `(sb-alien:null-alien ,obj) #+mcl `(ccl:%null-ptr-p ,obj) ) (defmacro make-null-pointer (type) #+(or allegro mcl) (declare (ignore type)) - #+cmu `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) + #+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) #+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type))) #+allegro 0 @@ -94,7 +93,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ) (defmacro char-array-to-pointer (obj) - #+cmu `(alien:cast ,obj (* (alien:unsigned 8))) + #+(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)) @@ -104,11 +103,11 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (defmacro deref-pointer (ptr type) "Returns a object pointed" - #+(or cmu sbcl lispworks) (declare (ignore type)) - #+cmu `(alien:deref ,ptr) + #+(or cmu sbcl lispworks scl) (declare (ignore type)) + #+(or cmu scl) `(alien:deref ,ptr) #+sbcl `(sb-alien:deref ,ptr) #+lispworks `(fli:dereference ,ptr) - #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr) + #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr) #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ) @@ -123,7 +122,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (defmacro ensure-char-character (obj) obj) -#+(or allegro cmu sbcl openmcl) +#+(or allegro cmu sbcl scl openmcl) (defmacro ensure-char-character (obj) `(code-char ,obj)) @@ -131,12 +130,12 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (defmacro ensure-char-integer (obj) `(char-code ,obj)) -#+(or allegro cmu sbcl openmcl) +#+(or allegro cmu sbcl scl openmcl) (defmacro ensure-char-integer (obj) obj) (defmacro pointer-address (obj) - #+cmu + #+(or cmu scl) `(system:sap-int (alien:alien-sap ,obj)) #+sbcl `(sb-sys:sap-int (sb-alien:alien-sap ,obj)) @@ -151,12 +150,12 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ;; TYPE is evaluated. #-mcl (defmacro with-foreign-object ((var type) &rest body) - #-(or cmu sbcl lispworks) ; default version + #-(or cmu sbcl lispworks scl) ; default version `(let ((,var (allocate-foreign-object ,type))) (unwind-protect (progn ,@body) (free-foreign-object ,var))) - #+cmu + #+(or cmu scl) (let ((obj (gensym))) `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate))) (let ((,var (alien:addr ,obj)))