From: Kevin M. Rosenberg Date: Thu, 14 Aug 2003 21:40:13 +0000 (+0000) Subject: r5496: def-foreign-var support X-Git-Tag: v1.6.1~194 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=db166e2970e1aaabd611e243eb899ae4d2f5f5ff r5496: def-foreign-var support --- diff --git a/debian/changelog b/debian/changelog index 93a93ed..e32c935 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.3.0-1) unstable; urgency=low + + * Add initial support and tests for def-foreign-var + + -- Kevin M. Rosenberg Thu, 14 Aug 2003 15:38:33 -0600 + cl-uffi (1.2.23-1) unstable; urgency=low * New upstream with fixes suggested and patches submitted by Edi Weitz. diff --git a/doc/ref.sgml b/doc/ref.sgml index cbf5336..99234c4 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -1515,7 +1515,7 @@ if a cstring returned by a function is &null;. Syntax - with-cast-pointer binding-name ptr type & body body => value + with-cast-pointer (binding-name ptr type) & body body => value @@ -1547,11 +1547,11 @@ if a cstring returned by a function is &null;. Description - Executes BODY with POINTER casted to be a pointer to type TYPE. If - BINDING-NAME is provided the casted pointer will be bound to this + Executes BODY with POINTER cast to be a pointer to type TYPE. If + BINDING-NAME is provided the cast pointer will be bound to this name during the execution of BODY. If BINDING-NAME is not provided POINTER must be a name bound to the pointer which should be - casted. This name will be bound to the casted pointer during the + cast. This name will be bound to the cast pointer during the execution of BODY. This is a no-op in AllegroCL but will wrap BODY in a LET form if @@ -1562,6 +1562,21 @@ if a cstring returned by a function is &null;. DEREF-POINTER or DEREF-ARRAY. + + Examples + +(with-foreign-object (size :int) + ;; FOO is a foreign function returning a :POINTER-VOID + (let ((memory (foo size))) + (when (mumble) + ;; at this point we know for some reason that MEMORY points + ;; to an array of unsigned bytes + (with-cast-pointer (memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + (do-something-with + (deref-array memory '(:array :unsigned-byte) i))))))) + + Side Effects None. diff --git a/src/objects.lisp b/src/objects.lisp index 9938a8e..26d1672 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: objects.lisp,v 1.16 2003/08/14 19:35:05 kevin Exp $ +;;;; $Id: objects.lisp,v 1.17 2003/08/14 21:40:13 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -228,3 +228,24 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." '(error "WITH-CAST-POINTER not (yet) implemented for ~A" (lisp-implementation-type))) +(defmacro def-foreign-var (names type module) + #-lispworks (declare (ignore module)) + (let ((foreign-name (if (atom names) names (first names))) + (lisp-name (if (atom names) (uffi::make-lisp-name names) (second names))) + (var-type (uffi::convert-from-uffi-type type :foreign-var))) + #+(or cmu scl) + `(alien:def-alien-variable (,foreign-name ,lisp-name) ,var-type) + #+sbcl + `(sb-alien:define-alien-variable (,foreign-name ,lisp-name) ,var-type) + #+allegro + `(ff:def-foreign-variable (,lisp-name ,foreign-name) :convention :c + :type ,var-type) + #+lispworks + (let ((temp-name (gensym))) + `(progn + (fli:define-foreign-variable (,temp-name ,foreign-name) :type ,var-type :module ,module) + (define-symbol-macro ,lisp-name (,temp-name)))) + #-(or allegro cmu scl sbcl lispworks) + `(define-symbol-macro ,lisp-name + '(error "DEF-FOREIGN-VAR not (yet) defined for ~A" + (lisp-implementation-type))))) diff --git a/src/package.lisp b/src/package.lisp index 7ccb110..54af538 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -50,6 +50,7 @@ #:+null-cstring-pointer+ #:char-array-to-pointer #:with-cast-pointer + #:def-foreign-var ;; string functions #:convert-from-cstring diff --git a/src/primitives.lisp b/src/primitives.lisp index 1af37b4..2bc63c2 100644 --- a/src/primitives.lisp +++ b/src/primitives.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.lisp,v 1.9 2003/06/06 21:59:18 kevin Exp $ +;;;; $Id: primitives.lisp,v 1.10 2003/08/14 21:40:13 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -82,15 +82,18 @@ supports takes advantage of this optimization." ) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar +type-conversion-hash+ (make-hash-table :size 20)) - #+(or cmu sbcl scl) (defvar *cmu-def-type-hash* (make-hash-table :size 20)) + (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq)) + #+(or cmu sbcl scl) (defvar *cmu-def-type-hash* + (make-hash-table :size 20 :test #'eq)) + #+allegro (defvar *allegro-foreign-type-hash* + (make-hash-table :size 20 :test #'eq)) ) #+(or cmu sbcl scl) -(defparameter *cmu-sbcl-def-type-list* nil) +(defvar *cmu-sbcl-def-type-list* nil) #+(or cmu scl) -(defparameter *cmu-sbcl-def-type-list* +(defvar *cmu-sbcl-def-type-list* '((:char . (alien:signed 8)) (:unsigned-char . (alien:unsigned 8)) (:byte . (alien:signed 8)) @@ -106,7 +109,7 @@ supports takes advantage of this optimization." ) "Conversions in CMUCL for def-foreign-type are different than in def-function") #+sbcl -(defparameter *cmu-sbcl-def-type-list* +(defvar *cmu-sbcl-def-type-list* '((:char . (sb-alien:signed 8)) (:unsigned-char . (sb-alien:unsigned 8)) (:byte . (sb-alien:signed 8)) @@ -122,7 +125,7 @@ supports takes advantage of this optimization." ) "Conversions in SBCL for def-foreign-type are different than in def-function") -(defparameter *type-conversion-list* nil) +(defvar *type-conversion-list* nil) #+(or cmu scl) (setq *type-conversion-list* @@ -222,6 +225,23 @@ supports takes advantage of this optimization." (:float . :single-float) (:double . :double-float) (:array . :array))) +#+allegro +(defvar *allegro-foreign-type-list* + '((:char . :signed-byte) + (:unsigned-char . :unsigned-byte) + (:byte . :signed-byte) + (:unsigned-byte . :unsigned-byte) + (:short . :signed-word) + (:unsigned-short . :unsigned-word) + (:int . :signed-long) + (:unsigned-int . :unsigned-long32) + (:long . :signed-long) + (:unsigned-long . :unsigned-long) + (:float . :single-float) + (:double . :double-float) + ) + "Conversion for Allegro's system:memref function") + (dolist (type *type-conversion-list*) (setf (gethash (car type) +type-conversion-hash+) (cdr type))) @@ -229,6 +249,14 @@ supports takes advantage of this optimization." (dolist (type *cmu-sbcl-def-type-list*) (setf (gethash (car type) *cmu-def-type-hash*) (cdr type))) +#+allegro +(dolist (type *allegro-foreign-type-list*) + (setf (gethash (car type) *allegro-foreign-type-hash*) (cdr type))) + +(defun foreign-var-type-convert (type) + #+allegro (gethash type *allegro-foreign-type-hash*)) + + (defun basic-convert-from-uffi-type (type) (let ((found-type (gethash type +type-conversion-hash+))) (if found-type @@ -256,6 +284,9 @@ supports takes advantage of this optimization." (basic-convert-from-uffi-type :cstring-returning)) #+(and mcl (not openmcl)) ((and (eq type :void) (eq context :return)) nil) + #+allegro + ((eq context :foreign-var) + (foreign-var-type-convert type)) (t (basic-convert-from-uffi-type type))) (let ((sub-type (car type))) diff --git a/tests/casts.lisp b/tests/casts.lisp index 4e19cfd..ae5ece4 100644 --- a/tests/casts.lisp +++ b/tests/casts.lisp @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: casts +;;;; Name: casts.lisp ;;;; Purpose: Tests of with-cast-pointer ;;;; Programmer: Kevin M. Rosenberg / Edi Weitz ;;;; Date Started: Aug 2003 ;;;; -;;;; $Id: casts.lisp,v 1.1 2003/08/14 19:35:05 kevin Exp $ +;;;; $Id: casts.lisp,v 1.2 2003/08/14 21:40:13 kevin Exp $ ;;;; ;;;; ************************************************************************* diff --git a/tests/foreign-loader.lisp b/tests/foreign-loader.lisp index 569b098..4cd8441 100644 --- a/tests/foreign-loader.lisp +++ b/tests/foreign-loader.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: foreign-loader.lisp,v 1.4 2003/08/13 18:53:42 kevin Exp $ +;;;; $Id: foreign-loader.lisp,v 1.5 2003/08/14 21:40:13 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -37,6 +37,7 @@ (list (pathname-directory *load-truename*) "/usr/lib/uffi/")) - :supporting-libraries '("c")) + :supporting-libraries '("c") + :module "uffi_tests") (warn "Unable to load uffi-c-test-lib library")) diff --git a/tests/foreign-var.lisp b/tests/foreign-var.lisp new file mode 100644 index 0000000..08a6e95 --- /dev/null +++ b/tests/foreign-var.lisp @@ -0,0 +1,34 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: foreign-var +;;;; Purpose: Tests of foreign variables +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id: foreign-var.lisp,v 1.1 2003/08/14 21:40:13 kevin Exp $ +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(def-foreign-var "uchar_13" :char "uffi_tests") +(def-foreign-var "schar_neg_120" :char "uffi_tests") +(def-foreign-var "uword_257" :unsigned-short "uffi_tests") +(def-foreign-var "sword_neg_321" :short "uffi_tests") +(def-foreign-var "uint_1234567" :int "uffi_tests") +(def-foreign-var "sint_neg_123456" :int "uffi_tests") +(def-foreign-var "float_neg_4_5" :float "uffi_tests") +(def-foreign-var "double_3_1" :double "uffi_tests") + +(deftest fvar.1 uchar-13 13) +(deftest fvar.2 schar-neg-120 -120) +(deftest fvar.3 uword-257 257) +(deftest fvar.4 sword-neg-321 -321) +(deftest fvar.5 uint-1234567 1234567) +(deftest fvar.6 sint-neg-123456 -123456) +(deftest fvar.7 float-neg-4-5 -4.5f0) +(deftest fvar.8 double-3-1 3.1d0) + + diff --git a/tests/uffi-c-test-lib.c b/tests/uffi-c-test-lib.c index c21a6e2..99b9004 100644 --- a/tests/uffi-c-test-lib.c +++ b/tests/uffi-c-test-lib.c @@ -6,7 +6,7 @@ * Programer: Kevin M. Rosenberg * Date Started: Mar 2002 * - * CVS Id: $Id: uffi-c-test-lib.c,v 1.2 2003/08/14 19:35:05 kevin Exp $ + * CVS Id: $Id: uffi-c-test-lib.c,v 1.3 2003/08/14 21:40:13 kevin Exp $ * * This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg * @@ -39,6 +39,15 @@ BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, #include +DLLEXPORT unsigned char uchar_13 = 13; +DLLEXPORT signed char schar_neg_120 = -120; +DLLEXPORT unsigned short uword_257 = 257; +DLLEXPORT signed short sword_neg_321 = -321; +DLLEXPORT unsigned int uint_1234567 = 1234567; +DLLEXPORT signed int sint_neg_123456 = -123456; +DLLEXPORT double double_3_1 = 3.1; +DLLEXPORT float float_neg_4_5 = -4.5; + /* Test of constant input string */ DLLEXPORT int diff --git a/uffi-tests.asd b/uffi-tests.asd index fc6e716..ebfa88e 100644 --- a/uffi-tests.asd +++ b/uffi-tests.asd @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: uffi-tests.asd,v 1.9 2003/08/14 19:35:05 kevin Exp $ +;;;; $Id: uffi-tests.asd,v 1.10 2003/08/14 21:40:13 kevin Exp $ ;;;; ************************************************************************* (defpackage #:uffi-tests-system @@ -34,6 +34,7 @@ (:file "uffi-c-test-lib" :depends-on ("foreign-loader")) (:file "compress" :depends-on ("foreign-loader")) (:file "casts" :depends-on ("foreign-loader")) + (:file "foreign-var" :depends-on ("foreign-loader")) )))) (defmethod perform ((o test-op) (c (eql (find-system :uffi-tests))))