From 7cb20f3bc266ede16dfcd449986136c43c4a2d57 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 21 Mar 2002 07:56:45 +0000 Subject: [PATCH 1/1] r1601: Added def-union, fixed ensure-char-* error --- ChangeLog | 7 +++++ Makefile | 4 +-- TODO | 8 ----- examples/{array-2d.cl => arrays.cl} | 38 ++++++++++++++++++++---- examples/union.cl | 46 +++++++++++++++++++++++++++++ src/aggregates.cl | 28 +++++++++++------- src/objects.cl | 7 ++--- test-examples.cl | 5 ++-- tests/{array-2d.cl => arrays.cl} | 38 ++++++++++++++++++++---- tests/union.cl | 46 +++++++++++++++++++++++++++++ 10 files changed, 190 insertions(+), 37 deletions(-) rename examples/{array-2d.cl => arrays.cl} (50%) create mode 100644 examples/union.cl rename tests/{array-2d.cl => arrays.cl} (50%) create mode 100644 tests/union.cl 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/arrays.cl similarity index 50% rename from examples/array-2d.cl rename to examples/arrays.cl index 5a95220..e9bbbaa 100644 --- a/examples/array-2d.cl +++ b/examples/arrays.cl @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: array-2d.cl -;;;; Purpose: UFFI Example file use 2-dimensional arrays +;;;; Name: arrays.cl +;;;; Purpose: UFFI Example file to test arrays ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: array-2d.cl,v 1.2 2002/03/18 22:47:57 kevin Exp $ +;;;; $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 ;;;; @@ -19,9 +19,10 @@ (in-package :cl-user) (uffi:def-constant +column-length+ 10) +(uffi:def-constant +row-length+ 10) -(defun test-array-2d () - "Tests 2d array" +(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))) @@ -30,6 +31,33 @@ (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/arrays.cl similarity index 50% rename from tests/array-2d.cl rename to tests/arrays.cl index 5a95220..e9bbbaa 100644 --- a/tests/array-2d.cl +++ b/tests/arrays.cl @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: array-2d.cl -;;;; Purpose: UFFI Example file use 2-dimensional arrays +;;;; Name: arrays.cl +;;;; Purpose: UFFI Example file to test arrays ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: array-2d.cl,v 1.2 2002/03/18 22:47:57 kevin Exp $ +;;;; $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 ;;;; @@ -19,9 +19,10 @@ (in-package :cl-user) (uffi:def-constant +column-length+ 10) +(uffi:def-constant +row-length+ 10) -(defun test-array-2d () - "Tests 2d array" +(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))) @@ -30,6 +31,33 @@ (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) -- 2.34.1