From 11f2368e2aa756f12f698ce3f2d5182d2299dafc Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 18 Mar 2002 22:47:57 +0000 Subject: [PATCH] r1588: Added array allocation to allocate-foreign-objects --- ChangeLog | 18 +++++++++++++++ Makefile | 4 ++-- examples/array-2d.cl | 13 +++++------ examples/strtol.cl | 5 ++--- src/objects.cl | 53 ++++++++++++++++++++++---------------------- src/primitives.cl | 9 +++----- src/strings.cl | 6 +++-- tests/array-2d.cl | 13 +++++------ tests/strtol.cl | 5 ++--- 9 files changed, 70 insertions(+), 56 deletions(-) diff --git a/ChangeLog b/ChangeLog index cc08f36..0a5a257 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,21 @@ +SCHEDULED CHANGES + * Change dereferencing of pointers to :char and :unsigned-char types. + May need to have ensure-char as routine to correctly handle setf + expansions. CMUCL strtol is broken because of signedness. + Right now, LW prefers unsigned and CMUCL prefers signed + string arrays. + * Need to clean signedness of allocate-foreign-string + +19 Mar 2002 + * Added size parameter to allocate-foreign-object. Creates an array + of dimensions size. + * Got array-2d example working with a 1-d array. + * Cleaned strtol example + +18 Mar 2002 + * Documentation fixes (Erik Winkels) + * Fixed missing '.' in CMUCL type declarations (Erik Winkels) + 17 Mar 2002 * Changed deref-pointer so it always returns a character when called with a :char or :unsigned-char type diff --git a/Makefile b/Makefile index cdfd876..4a836ba 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg, M.D. # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.22 2002/03/18 17:57:39 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.23 2002/03/18 22:47:57 kevin Exp $ # # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -31,7 +31,7 @@ realclean: clean docs: @(cd doc; make dist-doc) -VERSION=0.2.9-pre2 +VERSION=0.2.9 DISTDIR=uffi-${VERSION} DIST_TARBALL=${DISTDIR}.tar.gz DIST_ZIP=${DISTDIR}.zip diff --git a/examples/array-2d.cl b/examples/array-2d.cl index 9e344db..5a95220 100644 --- a/examples/array-2d.cl +++ b/examples/array-2d.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: array-2d.cl,v 1.1 2002/03/18 02:27:32 kevin Exp $ +;;;; $Id: array-2d.cl,v 1.2 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -20,16 +20,15 @@ (uffi:def-constant +column-length+ 10) -(uffi:def-array long-array (:long 10)) - (defun test-array-2d () "Tests 2d array" - (let ((a (uffi:allocate-foreign-object long-array))) + (let ((a (uffi:allocate-foreign-object :long +column-length+))) (dotimes (i +column-length+) - (setf (uffi:deref-array a :long i) (* i i))) + (setf (uffi:deref-array a '(:array :long) i) (* i i))) (dotimes (i +column-length+) - (format "~&~D => ~D" i (uffi:deref-array a 'long-array i))) - (uffi:free-foreign-object a))) + (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i))) + (uffi:free-foreign-object a)) + (values)) #+test-uffi (test-array-2d) diff --git a/examples/strtol.cl b/examples/strtol.cl index 63aea44..8beeddf 100644 --- a/examples/strtol.cl +++ b/examples/strtol.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strtol.cl,v 1.9 2002/03/17 17:33:30 kevin Exp $ +;;;; $Id: strtol.cl,v 1.10 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -38,8 +38,7 @@ of first non-valid character" (let* ((str-native (uffi:convert-to-foreign-string str)) (endptr (uffi:allocate-foreign-object char-ptr)) (value (c-strtol str-native endptr base)) - (endptr-value (uffi:deref-pointer endptr 'char-ptr)) - next-char-value chars-parsed) + (endptr-value (uffi:deref-pointer endptr 'char-ptr))) (unwind-protect (if (uffi:null-pointer-p endptr-value) diff --git a/src/objects.cl b/src/objects.cl index 0188430..f9651d4 100644 --- a/src/objects.cl +++ b/src/objects.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: objects.cl,v 1.7 2002/03/18 02:27:28 kevin Exp $ +;;;; $Id: objects.cl,v 1.8 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,14 +19,26 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :uffi) -(defmacro allocate-foreign-object (type) - #+cmu - `(alien:make-alien ,(convert-from-uffi-type 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) - ) +(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." + (if (eq size :unspecified) + (progn + #+cmu + `(alien:make-alien ,(convert-from-uffi-type 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)) + (progn + #+cmu + `(alien:make-alien ,(convert-from-uffi-type 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 type :allocate) ,(eval size)) :c) + ) + )) (defmacro free-foreign-object (obj) #+cmu @@ -54,18 +66,10 @@ (defmacro deref-pointer (ptr type) "Returns a object pointed" - (let ((result (gensym))) - `(let ((,result - #+cmu (alien:deref ,ptr) - #+lispworks (fli:dereference ,ptr) - #+allegro (ff:fslot-value-typed ,type :c ,ptr) - )) - (if (and - (or (eq ,type :char) - (eq ,type :unsigned-char)) - (numberp ,result)) - (code-char ,result) - ,result)))) + #+cmu `(alien:deref ,ptr) + #+lispworks `(fli:dereference ,ptr) + #+allegro `(ff:fslot-value-typed ,type :c ,ptr) +) (defmacro pointer-address (obj) #+cmu @@ -76,6 +80,7 @@ obj ) +#| (defmacro allocate-byte-array (nsize) #+cmu `(alien:make-alien (alien:unsigned 8) ,nsize) @@ -90,8 +95,4 @@ #+lispworks `(fli:dereference ,array :index ,position) #+allegro `(ff:fslot-value-typed '(:array :byte) :c ,array ,position) ) - - - - -) +|# diff --git a/src/primitives.cl b/src/primitives.cl index 40bc449..c113bdf 100644 --- a/src/primitives.cl +++ b/src/primitives.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.cl,v 1.9 2002/03/18 02:27:28 kevin Exp $ +;;;; $Id: primitives.cl,v 1.10 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -37,11 +37,8 @@ supports takes advantage of this optimization." ) (defmacro null-char-p (val) - `(if (or (eql ,val 0) - (eq ,val #\Null)) - t - nil)) - + "Returns T if character is NULL" + `(zerop ,val)) (defmacro def-foreign-type (name type) #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) diff --git a/src/strings.cl b/src/strings.cl index 95fdadf..a32edde 100644 --- a/src/strings.cl +++ b/src/strings.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.cl,v 1.6 2002/03/17 17:33:30 kevin Exp $ +;;;; $Id: strings.cl,v 1.7 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -118,7 +118,9 @@ that CMU automatically converts strings from c-calls." ) -(defmacro allocate-foreign-string (size &key (unsigned t)) +(defmacro allocate-foreign-string (size &key (unsigned + #+cmu nil + #+lispworks t)) #+cmu (let ((array-def (gensym))) `(let ((,array-def (list 'alien:array 'c-call:char ,size))) diff --git a/tests/array-2d.cl b/tests/array-2d.cl index 9e344db..5a95220 100644 --- a/tests/array-2d.cl +++ b/tests/array-2d.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: array-2d.cl,v 1.1 2002/03/18 02:27:32 kevin Exp $ +;;;; $Id: array-2d.cl,v 1.2 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -20,16 +20,15 @@ (uffi:def-constant +column-length+ 10) -(uffi:def-array long-array (:long 10)) - (defun test-array-2d () "Tests 2d array" - (let ((a (uffi:allocate-foreign-object long-array))) + (let ((a (uffi:allocate-foreign-object :long +column-length+))) (dotimes (i +column-length+) - (setf (uffi:deref-array a :long i) (* i i))) + (setf (uffi:deref-array a '(:array :long) i) (* i i))) (dotimes (i +column-length+) - (format "~&~D => ~D" i (uffi:deref-array a 'long-array i))) - (uffi:free-foreign-object a))) + (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i))) + (uffi:free-foreign-object a)) + (values)) #+test-uffi (test-array-2d) diff --git a/tests/strtol.cl b/tests/strtol.cl index 63aea44..8beeddf 100644 --- a/tests/strtol.cl +++ b/tests/strtol.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strtol.cl,v 1.9 2002/03/17 17:33:30 kevin Exp $ +;;;; $Id: strtol.cl,v 1.10 2002/03/18 22:47:57 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -38,8 +38,7 @@ of first non-valid character" (let* ((str-native (uffi:convert-to-foreign-string str)) (endptr (uffi:allocate-foreign-object char-ptr)) (value (c-strtol str-native endptr base)) - (endptr-value (uffi:deref-pointer endptr 'char-ptr)) - next-char-value chars-parsed) + (endptr-value (uffi:deref-pointer endptr 'char-ptr))) (unwind-protect (if (uffi:null-pointer-p endptr-value) -- 2.34.1