From: Kevin M. Rosenberg Date: Thu, 21 Mar 2002 07:56:45 +0000 (+0000) Subject: r1601: Added def-union, fixed ensure-char-* error X-Git-Tag: v1.6.1~565 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=7cb20f3bc266ede16dfcd449986136c43c4a2d57;hp=ddf36af16030d4e73202782f6811466e4b6b29a3;p=uffi.git r1601: Added def-union, fixed ensure-char-* error --- diff --git a/ChangeLog b/ChangeLog index 4ff03b9..1d69f94 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,12 @@ See TODO file -- actively maintained. Includes changes that you might expect in the interface. + +21 Mar 2002 + * Fixed problem with NULL foreign-strings with CMUCL + * Added c-test-fns to examples for allow more specific testing + of UFFI. Builds on UNIX and Win32 platforms. + * Added def-union function, added union.cl example + * Fixed error with ensure-char-[character|integer] 20 Mar 2002 * Updated strings.cl so that foreign-strings are always unsigned. diff --git a/Makefile b/Makefile index f43cf4d..8191f53 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.25 2002/03/19 16:42:58 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.26 2002/03/21 07:56:45 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.10 +VERSION=0.2.11 DISTDIR=uffi-${VERSION} DIST_TARBALL=${DISTDIR}.tar.gz DIST_ZIP=${DISTDIR}.zip diff --git a/TODO b/TODO index f8940da..fb4f2c8 100644 --- a/TODO +++ b/TODO @@ -7,13 +7,5 @@ like CMUCL which doesn't evaluate the type argument. - Cleanup the meaning of (def-array). Add size parameter -- 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. I lean -to having unsigned be the default type. - -- Add def-union routine - - Split implementation-dependent code into separate files in preparation for MCL and CormanLisp ports. diff --git a/examples/array-2d.cl b/examples/array-2d.cl deleted file mode 100644 index 5a95220..0000000 --- a/examples/array-2d.cl +++ /dev/null @@ -1,36 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: array-2d.cl -;;;; Purpose: UFFI Example file use 2-dimensional arrays -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $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 -;;;; -;;;; 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 :cl-user) - -(uffi:def-constant +column-length+ 10) - -(defun test-array-2d () - "Tests 2d array" - (let ((a (uffi:allocate-foreign-object :long +column-length+))) - (dotimes (i +column-length+) - (setf (uffi:deref-array a '(:array :long) i) (* i i))) - (dotimes (i +column-length+) - (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/arrays.cl b/examples/arrays.cl new file mode 100644 index 0000000..e9bbbaa --- /dev/null +++ b/examples/arrays.cl @@ -0,0 +1,64 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: arrays.cl +;;;; Purpose: UFFI Example file to test arrays +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: arrays.cl,v 1.1 2002/03/21 07:56:45 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 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 :cl-user) + +(uffi:def-constant +column-length+ 10) +(uffi:def-constant +row-length+ 10) + +(defun test-array-1d () + "Tests vector" + (let ((a (uffi:allocate-foreign-object :long +column-length+))) + (dotimes (i +column-length+) + (setf (uffi:deref-array a '(:array :long) i) (* i i))) + (dotimes (i +column-length+) + (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i))) + (uffi:free-foreign-object a)) + (values)) + +(defun test-array-2d () + "Tests 2d array" + (let ((a (uffi:allocate-foreign-object (* :long) +row-length+))) + (dotimes (r +row-length+) + (declare (fixnum r)) + (setf (uffi:deref-array a '(:array (* :long)) r) + (uffi:allocate-foreign-object :long +column-length+)) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c))))) + + (dotimes (r +row-length+) + (declare (fixnum r)) + (format t "~&Row ~D: " r) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (let ((result (uffi:deref-array col '(:array :long) c))) + (format t "~d " result))))) + + (uffi:free-foreign-object a)) + (values)) + +#+test-uffi +(test-array-1d) + +#+test-uffi +(test-array-2d) + + diff --git a/examples/union.cl b/examples/union.cl new file mode 100644 index 0000000..197332f --- /dev/null +++ b/examples/union.cl @@ -0,0 +1,46 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: union.cl +;;;; Purpose: UFFI Example file to test unions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: union.cl,v 1.1 2002/03/21 07:56:45 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 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 :cl-user) + +(uffi:def-union tunion1 + (char :char) + (int :int) + (uint :unsigned-int) + (sf :float) + (df :double)) + +(defun test-union-1 () + (let ((u (uffi:allocate-foreign-object tunion1))) + (setf (uffi:get-slot-value u 'tunion1 'int) + (+ (char-code #\A) + (* 256 (char-code #\B)) + (* 65536 (char-code #\C)) + (* 16777216 255))) + (format t "~&Should be #\A: ~S" + (uffi:ensure-char-character + (uffi:get-slot-value u 'tunion1 'char))) + (format t "~&Should be negative number: ~D" + (uffi:get-slot-value u 'tunion1 'int)) + (format t "~&Should be positive number: ~D" + (uffi:get-slot-value u 'tunion1 'uint)) + (uffi:free-foreign-object u)) + (values)) + +#+uffi-test +(test-union-1) diff --git a/src/aggregates.cl b/src/aggregates.cl index 3bb97f9..06dca81 100644 --- a/src/aggregates.cl +++ b/src/aggregates.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: aggregates.cl,v 1.6 2002/03/17 17:33:30 kevin Exp $ +;;;; $Id: aggregates.cl,v 1.7 2002/03/21 07:56:45 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -61,11 +61,11 @@ of the enum-name name, separator-string, and field-name" (* ,(convert-from-uffi-type type :array))) ) -(defun process-struct-args (name args) +(defun process-struct-fields (name fields) (let (processed) - (dolist (arg args) - (let ((field-name (car arg)) - (type (cadr arg))) + (dolist (field fields) + (let ((field-name (car field)) + (type (cadr field))) (push (append (list field-name) (if (eq type :pointer-self) #+cmu `((* (alien:struct ,name))) @@ -75,13 +75,13 @@ of the enum-name name, separator-string, and field-name" (nreverse processed))) -(defmacro def-struct (name &rest args) +(defmacro def-struct (name &rest fields) #+cmu - `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-args name args))) + `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) #+allegro - `(ff:def-foreign-type ,name (:struct ,@(process-struct-args name args))) + `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) #+lispworks - `(fli:define-c-struct ,name ,@(process-struct-args name args)) + `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) ) @@ -113,7 +113,13 @@ of the enum-name name, separator-string, and field-name" #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i) ) - - +(defmacro def-union (name &rest fields) + #+allegro + `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-union ,name ,@(process-struct-fields name fields)) + #+cmu + `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) +) diff --git a/src/objects.cl b/src/objects.cl index fdecab2..1ac0ad8 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.9 2002/03/19 16:42:59 kevin Exp $ +;;;; $Id: objects.cl,v 1.10 2002/03/21 07:56:45 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -74,22 +74,21 @@ an array of TYPE with size SIZE." #+lispworks ;; with LW, deref is a character (defmacro ensure-char-character (obj) - "Ensures that the dereference of a :char is a character" + obj ) #+(or allegro cmu) (defmacro ensure-char-character (obj) - "Ensures that the dereference of a :char is a character" `(code-char ,obj) ) #+lispworks (defmacro ensure-char-integer (obj) - "Ensures that the dereference of a :char is a character" `(char-code ,obj)) #+(or allegro cmu) (defmacro ensure-char-integer (obj) + obj ) ;; (* :char) dereference is already an integer (defmacro pointer-address (obj) diff --git a/test-examples.cl b/test-examples.cl index 5ff2f58..301e9cd 100644 --- a/test-examples.cl +++ b/test-examples.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: test-examples.cl,v 1.6 2002/03/21 04:05:15 kevin Exp $ +;;;; $Id: test-examples.cl,v 1.7 2002/03/21 07:56:45 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -28,7 +28,8 @@ *load-truename*)))) (load-test "c-test-fns") - (load-test "array-2d") + (load-test "arrays") + (load-test "union") (load-test "strtol") (load-test "gettime") (load-test "getenv") diff --git a/tests/array-2d.cl b/tests/array-2d.cl deleted file mode 100644 index 5a95220..0000000 --- a/tests/array-2d.cl +++ /dev/null @@ -1,36 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: array-2d.cl -;;;; Purpose: UFFI Example file use 2-dimensional arrays -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $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 -;;;; -;;;; 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 :cl-user) - -(uffi:def-constant +column-length+ 10) - -(defun test-array-2d () - "Tests 2d array" - (let ((a (uffi:allocate-foreign-object :long +column-length+))) - (dotimes (i +column-length+) - (setf (uffi:deref-array a '(:array :long) i) (* i i))) - (dotimes (i +column-length+) - (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/arrays.cl b/tests/arrays.cl new file mode 100644 index 0000000..e9bbbaa --- /dev/null +++ b/tests/arrays.cl @@ -0,0 +1,64 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: arrays.cl +;;;; Purpose: UFFI Example file to test arrays +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: arrays.cl,v 1.1 2002/03/21 07:56:45 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 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 :cl-user) + +(uffi:def-constant +column-length+ 10) +(uffi:def-constant +row-length+ 10) + +(defun test-array-1d () + "Tests vector" + (let ((a (uffi:allocate-foreign-object :long +column-length+))) + (dotimes (i +column-length+) + (setf (uffi:deref-array a '(:array :long) i) (* i i))) + (dotimes (i +column-length+) + (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i))) + (uffi:free-foreign-object a)) + (values)) + +(defun test-array-2d () + "Tests 2d array" + (let ((a (uffi:allocate-foreign-object (* :long) +row-length+))) + (dotimes (r +row-length+) + (declare (fixnum r)) + (setf (uffi:deref-array a '(:array (* :long)) r) + (uffi:allocate-foreign-object :long +column-length+)) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c))))) + + (dotimes (r +row-length+) + (declare (fixnum r)) + (format t "~&Row ~D: " r) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (let ((result (uffi:deref-array col '(:array :long) c))) + (format t "~d " result))))) + + (uffi:free-foreign-object a)) + (values)) + +#+test-uffi +(test-array-1d) + +#+test-uffi +(test-array-2d) + + diff --git a/tests/union.cl b/tests/union.cl new file mode 100644 index 0000000..197332f --- /dev/null +++ b/tests/union.cl @@ -0,0 +1,46 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: union.cl +;;;; Purpose: UFFI Example file to test unions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: union.cl,v 1.1 2002/03/21 07:56:45 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 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 :cl-user) + +(uffi:def-union tunion1 + (char :char) + (int :int) + (uint :unsigned-int) + (sf :float) + (df :double)) + +(defun test-union-1 () + (let ((u (uffi:allocate-foreign-object tunion1))) + (setf (uffi:get-slot-value u 'tunion1 'int) + (+ (char-code #\A) + (* 256 (char-code #\B)) + (* 65536 (char-code #\C)) + (* 16777216 255))) + (format t "~&Should be #\A: ~S" + (uffi:ensure-char-character + (uffi:get-slot-value u 'tunion1 'char))) + (format t "~&Should be negative number: ~D" + (uffi:get-slot-value u 'tunion1 'int)) + (format t "~&Should be positive number: ~D" + (uffi:get-slot-value u 'tunion1 'uint)) + (uffi:free-foreign-object u)) + (values)) + +#+uffi-test +(test-union-1)