From: Kevin M. Rosenberg Date: Thu, 14 Aug 2003 19:35:05 +0000 (+0000) Subject: r5495: *** empty log message *** X-Git-Tag: v1.6.1~195 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=77fd04d570b9ae1fd40c1f7b0134af826576210b r5495: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 128e210..93a93ed 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.2.23-1) unstable; urgency=low + + * New upstream with fixes suggested and patches submitted by Edi Weitz. + + -- Kevin M. Rosenberg Thu, 14 Aug 2003 12:26:07 -0600 + cl-uffi (1.2.22-1) unstable; urgency=low * New upstream with Lispworks patch from Edi Weitz diff --git a/doc/html.tar.gz b/doc/html.tar.gz index e36f2ce..f3dcd22 100644 Binary files a/doc/html.tar.gz and b/doc/html.tar.gz differ diff --git a/doc/ref.sgml b/doc/ref.sgml index 510dd4c..cbf5336 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -759,7 +759,7 @@ the array. Examples -(def-array ca :char) +(def-array-pointer ca :char) (let ((fs (convert-to-foreign-string "ab"))) (values (null-char-p (deref-array fs 'ca 0)) (null-char-p (deref-array fs 'ca 2)))) @@ -767,6 +767,14 @@ the array. &t; + + Notes + + The TYPE argument is ignored for CL implementations other than + AllegroCL. If you want to cast a pointer to another type use + WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY. + + Side Effects None. @@ -1216,6 +1224,14 @@ much better with static allocation. + + Notes + + The TYPE argument is ignored for CL implementations other than + AllegroCL. If you want to cast a pointer to another type use + WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY. + + Side Effects None. @@ -1266,8 +1282,9 @@ a character. Description - Ensures that an object obtained by dereferencing a -:char pointer is a character. + Ensures that an objects obtained by dereferencing +:char and :unsigned-char +pointers are a lisp character. @@ -1488,6 +1505,77 @@ if a cstring returned by a function is &null;. + + + with-cast-pointer + Wraps a body of code with a pointer cast to a new type. + + Macro + + + Syntax + + with-cast-pointer binding-name ptr type & body body => value + + + + Arguments and Values + + + ptr + + A pointer to a foreign object. + + + + + type + + A foreign type of the object being pointed to. + + + + + value + + The value of the object where the pointer points. + + + + + + + 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 + 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 + execution of BODY. + + This is a no-op in AllegroCL but will wrap BODY in a LET form if + BINDING-NAME is provided. + + This macro is meant to be used in conjunction with DEREF-POINTER or + DEREF-ARRAY. In Allegro CL the "cast" will actually take place in + DEREF-POINTER or DEREF-ARRAY. + + + + Side Effects + None. + + + Affected by + None. + + + Exceptional Situations + None. + + + @@ -2074,7 +2162,7 @@ foreign function. If :void indicates module does not return Syntax - load-foreign-library filename &key module supporting-libraries => success + load-foreign-library filename &key module supporting-libraries force-load => success @@ -2105,6 +2193,13 @@ link the foreign library. (Required by CMUCL) + + force-load + + Forces the loading of the library if it has been previously loaded. + + + success @@ -2120,7 +2215,7 @@ otherwise &nil;. Description Loads a foreign library. Applies a module name to functions within the library. Ensures that a library is only loaded once during -a session. +a session. A library can be reloaded by using the :force-load key. diff --git a/doc/uffi.pdf b/doc/uffi.pdf index 7c2530b..f2b7c60 100644 Binary files a/doc/uffi.pdf and b/doc/uffi.pdf differ diff --git a/src/libraries.lisp b/src/libraries.lisp index ff14928..0944335 100644 --- a/src/libraries.lisp +++ b/src/libraries.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: libraries.lisp,v 1.9 2003/07/08 12:37:21 kevin Exp $ +;;;; $Id: libraries.lisp,v 1.10 2003/08/14 19:35:05 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -72,7 +72,7 @@ library type if type is not specified." (defun load-foreign-library (filename &key module supporting-libraries force-load) - #+(or allegro lispworks mcl) (declare (ignore module supporting-libraries)) + #+(or allegro mcl) (declare (ignore module supporting-libraries)) #+(or cmu scl sbcl) (declare (ignore module)) (when (and filename (probe-file filename)) diff --git a/src/objects.lisp b/src/objects.lisp index 4930962..9938a8e 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.15 2003/07/08 12:37:21 kevin Exp $ +;;;; $Id: objects.lisp,v 1.16 2003/08/14 19:35:05 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -118,7 +118,11 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+mcl (defsetf deref-pointer deref-pointer-set) -#+(or lispworks (and mcl (not openmcl))) ;; with LW, deref is a character +#+lispworks +(defmacro ensure-char-character (obj) + `(if (characterp ,obj) ,obj (code-char ,obj))) + +#+(and mcl (not openmcl)) (defmacro ensure-char-character (obj) obj) @@ -197,3 +201,30 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(with-foreign-objects ((,var ,type)) ,@body)) +#+lispworks +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + `(fli:with-coerced-pointer (,binding-name + :type ',(convert-from-uffi-type (eval type) :type)) + ,pointer + ,@body)) + +#+(or cmu scl sbcl) +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + `(let ((,binding-name + (#+(or cmu scl) alien:cast + #+sbcl sb-alien:cast + ,pointer (* ,(convert-from-uffi-type (eval type) :type))))) + ,@body)) + +#+allegro +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + (declare (ignore type)) + `(let ((,binding-name ,pointer)) + ,@body)) + +#-(or lispworks cmu scl sbcl allegro) +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + (declare (ignore binding-name pointer type)) + '(error "WITH-CAST-POINTER not (yet) implemented for ~A" + (lisp-implementation-type))) + diff --git a/src/package.lisp b/src/package.lisp index 9bd1b09..7ccb110 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -49,6 +49,7 @@ #:make-null-pointer #:+null-cstring-pointer+ #:char-array-to-pointer + #:with-cast-pointer ;; string functions #:convert-from-cstring diff --git a/tests/casts.lisp b/tests/casts.lisp new file mode 100644 index 0000000..4e19cfd --- /dev/null +++ b/tests/casts.lisp @@ -0,0 +1,47 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: casts +;;;; 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 $ +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-function ("cast_test_int" cast-test-int) + () + :returning :pointer-void) + +(uffi:def-function ("cast_test_float" cast-test-float) + () + :returning :pointer-void) + +(deftest cast.1 + (progn + (uffi:with-cast-pointer (temp (cast-test-int) :int) + (assert (= (uffi:deref-pointer temp :int) 23))) + (let ((result (cast-test-int))) + (uffi:with-cast-pointer (result2 result :int) + (assert (= (uffi:deref-pointer result2 :int) 23))) + (uffi:with-cast-pointer (temp result :int) + (assert (= (uffi:deref-pointer temp :int) 23)))) + t) + t) + +(deftest cast.2 + (progn + (uffi:with-cast-pointer (temp (cast-test-float) :double) + (assert (= (uffi:deref-pointer temp :double) 3.21d0))) + (let ((result (cast-test-float))) + (uffi:with-cast-pointer (result2 result :double) + (assert (= (uffi:deref-pointer result2 :double) 3.21d0))) + (uffi:with-cast-pointer (temp result :double) + (assert (= (uffi:deref-pointer temp :double) 3.21d0)))) + t) + t) + diff --git a/tests/pointers.lisp b/tests/pointers.lisp new file mode 100644 index 0000000..9f704ff --- /dev/null +++ b/tests/pointers.lisp @@ -0,0 +1,41 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pointers.lisp +;;;; Purpose: Test file for UFFI pointers +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id: pointers.lisp,v 1.1 2003/08/14 19:35:05 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2003 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(deftest chptr.1 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (characterp + (ensure-char-character + (deref-pointer fs :char))))) + t) + +(deftest chptr.2 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (characterp + (ensure-char-character + (deref-pointer fs :unsigned-char))))) + t) + +(deftest chptr.3 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (numberp + (deref-pointer fs :byte)))) + t) + + diff --git a/tests/structs.lisp b/tests/structs.lisp index 1522a15..8518eec 100644 --- a/tests/structs.lisp +++ b/tests/structs.lisp @@ -3,13 +3,13 @@ ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: structs.lisp -;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic +;;;; Purpose: Test file for UFFI structures ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: structs.lisp,v 1.1 2003/08/13 18:53:42 kevin Exp $ +;;;; $Id: structs.lisp,v 1.2 2003/08/14 19:35:05 kevin Exp $ ;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of UFFI, is Copyright (c) 2002-2003 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* @@ -23,12 +23,9 @@ (uffi:def-foreign-type foo-ptr (* foo)) -(uffi:def-function "baz" - ((x :int)) - :returning foo-ptr - :module "frob") - -(defun test () +;; tests that compilation worked +(deftest structs.1 (with-foreign-object (p 'foo) - (baz p))) + t) + t) diff --git a/tests/uffi-c-test-lib.c b/tests/uffi-c-test-lib.c index d8e9b49..c21a6e2 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.1 2003/04/29 14:08:02 kevin Exp $ + * CVS Id: $Id: uffi-c-test-lib.c,v 1.2 2003/08/14 19:35:05 kevin Exp $ * * This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg * @@ -93,3 +93,19 @@ half_double_vector (int size, double* vec) +DLLEXPORT +void * +cast_test_int () { + int *x = (int *) malloc(sizeof(int)); + *x = 23; + return x; +} + +DLLEXPORT +void * +cast_test_float () +{ + double *y = (double *) malloc(sizeof(double)); + *y = 3.21; + return y; +} diff --git a/uffi-tests.asd b/uffi-tests.asd index 6845a74..fc6e716 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.8 2003/08/13 18:53:42 kevin Exp $ +;;;; $Id: uffi-tests.asd,v 1.9 2003/08/14 19:35:05 kevin Exp $ ;;;; ************************************************************************* (defpackage #:uffi-tests-system @@ -28,10 +28,12 @@ (:file "union" :depends-on ("package")) (:file "arrays" :depends-on ("package")) (:file "structs" :depends-on ("package")) + (:file "pointers" :depends-on ("package")) (:file "time" :depends-on ("package")) (:file "foreign-loader" :depends-on ("package")) - (:file "compress" :depends-on ("foreign-loader")) (:file "uffi-c-test-lib" :depends-on ("foreign-loader")) + (:file "compress" :depends-on ("foreign-loader")) + (:file "casts" :depends-on ("foreign-loader")) )))) (defmethod perform ((o test-op) (c (eql (find-system :uffi-tests)))) diff --git a/uffi.asd b/uffi.asd index dbdb11c..84ae54d 100644 --- a/uffi.asd +++ b/uffi.asd @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: uffi.asd,v 1.27 2003/07/18 21:33:25 kevin Exp $ +;;;; $Id: uffi.asd,v 1.28 2003/08/14 19:35:05 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -46,6 +46,6 @@ #+(or allegro lispworks cmu mcl cormanlisp sbcl scl) (defmethod perform ((o test-op) (c (eql (find-system 'uffi)))) (oos 'load-op 'uffi-tests) - (oos 'test-op 'uffi-tests)) + (oos 'test-op 'uffi-tests :force t))