X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fobjects.lisp;h=0e327f0269d4d457da27b457de85fc3657caa5b5;hb=6b108d27ffc3f4e08f2529e71911ed02a5310a6d;hp=42ab3fc334fe0b3266fe477f46a19df2dcdcf3f6;hpb=25845009fdd5e3d2fbb875027d71fdd47d76ea13;p=uffi.git diff --git a/src/objects.lisp b/src/objects.lisp index 42ab3fc..0e327f0 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -9,29 +9,26 @@ ;;;; ;;;; $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)) + #+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 + #+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 @@ -46,7 +43,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate)) #+allegro `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c) - #+mcl + #+(or openmcl digitool) `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) ) (progn @@ -58,7 +55,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(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) - #+mcl + #+(or openmcl digitool) `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) ))) @@ -71,7 +68,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:free-foreign-object ,obj) #+allegro `(ff:free-fobject ,obj) - #+mcl + #+(or openmcl digitool) `(dispose-ptr ,obj) ) @@ -80,33 +77,27 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+allegro `(zerop ,obj) #+(or cmu scl) `(alien:null-alien ,obj) #+sbcl `(sb-alien:null-alien ,obj) - #+mcl `(ccl:%null-ptr-p ,obj) + #+(or openmcl digitool) `(ccl:%null-ptr-p ,obj) ) (defmacro make-null-pointer (type) - #+(or allegro mcl) (declare (ignore type)) + #+(or allegro openmcl digitool) (declare (ignore 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 - #+mcl `(ccl:%null-ptr) + #+(or openmcl digitool) `(ccl:%null-ptr) ) (defmacro make-pointer (addr type) - #+(or allegro mcl) (declare (ignore type)) + #+(or allegro openmcl digitool) (declare (ignore type)) #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type))) #+allegro addr - #+mcl `(ccl:%int-to-ptr ,addr) + #+(or openmcl digitool) `(ccl:%int-to-ptr ,addr) ) -(defmacro pointer-address (ptr) - #+allegro ptr - #+(or cmu scl) `(system:sap-int (alien:alien-sap ,ptr)) - #+sbcl `(sb-sys:sap-int (sb-alien:alien-sap ,ptr)) - #+lispworks `(fli:pointer-address ,ptr) - #+mcl `(ccl:%ptr-to-int ,ptr)) (defmacro char-array-to-pointer (obj) #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8))) @@ -114,7 +105,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+lispworks `(fli:make-pointer :type '(:unsigned :char) :address (fli:pointer-address ,obj)) #+allegro obj - #+mcl obj + #+(or openmcl digitool) obj ) (defmacro deref-pointer (ptr type) @@ -124,35 +115,32 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+sbcl `(sb-alien:deref ,ptr) #+lispworks `(fli:dereference ,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)) + #+(or openmcl digitool) `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ) -#+mcl +#+digitool (defmacro deref-pointer-set (ptr type value) `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) -#+mcl +#+digitool (defsetf deref-pointer deref-pointer-set) -#+lispworks (defmacro ensure-char-character (obj) - `(if (characterp ,obj) ,obj (code-char ,obj))) + #+(or digitool) 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))) -#+(and mcl (not openmcl)) -(defmacro ensure-char-character (obj) - obj) - -#+(or allegro cmu sbcl scl openmcl) -(defmacro ensure-char-character (obj) - `(code-char ,obj)) - -#+(or lispworks (and mcl (not openmcl))) (defmacro ensure-char-integer (obj) - `(char-code ,obj)) + #+(or digitool) `(char-code ,obj) + #+(or allegro cmu sbcl scl openmcl) obj + ;; lispworks varies whether deref'ing array vs. slot access of a char + #+lispworks + `(if (integerp ,obj) ,obj (char-code ,obj))) -#+(or allegro cmu sbcl scl openmcl) -(defmacro ensure-char-integer (obj) - obj) +(defmacro ensure-char-storable (obj) + #+(or lispworks digitool) obj + #+(or allegro cmu sbcl scl openmcl) `(char-code ,obj)) (defmacro pointer-address (obj) #+(or cmu scl) @@ -163,12 +151,12 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:pointer-address ,obj) #+allegro obj - #+mcl - `(ccl:%ptr-to-int ,obj) + #+(or openmcl digitool) + `(ccl:%ptr-to-int ,obj) ) ;; TYPE is evaluated. -#-mcl +#-(or openmcl digitool) (defmacro with-foreign-object ((var type) &rest body) #-(or cmu sbcl lispworks scl) ; default version `(let ((,var (allocate-foreign-object ,type))) @@ -176,22 +164,32 @@ 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))) - `(sb-alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate))) - (let ((,var (sb-alien:addr ,obj))) - ,@body))) + (let ((obj (gensym)) + (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)))) #+lispworks `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type (eval type) :allocate))) ,@body) ) -#-mcl +#-(or openmcl digitool) (defmacro with-foreign-objects (bindings &rest body) (if bindings `(with-foreign-object ,(car bindings) @@ -199,7 +197,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ,@body)) `(progn ,@body))) -#+mcl +#+(or openmcl digitool) (defmacro with-foreign-objects (bindings &rest body) (let ((params nil) type count) (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* @@ -211,10 +209,10 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (setf type (nth 1 type))) (push (list (first spec) (* count (size-of-foreign-type type))) params)) `(ccl:%stack-block ,params ,@body))) - -#+mcl + +#+(or openmcl digitool) (defmacro with-foreign-object ((var type) &rest body) - `(with-foreign-objects ((,var ,type)) + `(with-foreign-objects ((,var ,type)) ,@body)) #+lispworks @@ -238,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))) @@ -257,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) @@ -266,7 +270,21 @@ 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))))) + + +;;; Define a special variable, like DEFVAR, that will be initialized +;;; to a pointer which may need to be reset when a saved image is +;;; loaded. This is needed for OpenMCL, which sets pointers to "dead +;;; macptrs" when a saved image is loaded. +;; This may possibly be needed for sbcl's SAVE-LISP-AND-DIE +(defmacro def-pointer-var (name value &optional doc) + #-openmcl `(defvar ,name ,value ,@(if doc (list doc))) + #+openmcl `(ccl::defloadvar ,name ,value ,doc))