OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR libfortran/40187 (c_f_pointer with stride in SHAPE) 

2009-05-27  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/40187
	* intrinsics/iso_c_binding.c (c_f_pointer_u0):  Take care
	of stride in "shape" argument.

2009-05-27  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/40187
	* gfortran.dg/c_f_pointer_shape_tests_4.f03:  New file.
	* gfortran.dg/c_f_pointer_shape_tests_4_driver.c:  New file.

From-SVN: r147894
This commit is contained in:
Thomas Koenig 2009-05-27 05:27:31 +00:00
parent 82f331ff93
commit 230fa1fc73
5 changed files with 207 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2009-05-27 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/40187
* gfortran.dg/c_f_pointer_shape_tests_4.f03: New file.
* gfortran.dg/c_f_pointer_shape_tests_4_driver.c: New file.
2009-05-26 Tobias Burnus <burnus@net-b.de>
PR fortran/40246

115
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 Normal file
View File

@ -0,0 +1,115 @@
! { dg-do run }
! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c }
! Verify that the optional SHAPE parameter to c_f_pointer can be of any
! valid integer kind. We don't test all kinds here since it would be
! difficult to know what kinds are valid for the architecture we're running on.
! However, testing ones that should be different should be sufficient.
module c_f_pointer_shape_tests_4
use, intrinsic :: iso_c_binding
implicit none
contains
subroutine test_long_long_1d(cPtr, num_elems) bind(c)
use, intrinsic :: iso_c_binding
type(c_ptr), value :: cPtr
integer(c_int), value :: num_elems
integer, dimension(:), pointer :: myArrayPtr
integer(c_long_long), dimension(1) :: shape
integer :: i
shape(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_long_long_1d
subroutine test_long_long_2d(cPtr, num_rows, num_cols) bind(c)
use, intrinsic :: iso_c_binding
type(c_ptr), value :: cPtr
integer(c_int), value :: num_rows
integer(c_int), value :: num_cols
integer, dimension(:,:), pointer :: myArrayPtr
integer(c_long_long), dimension(3) :: shape
integer :: i,j
shape(1) = num_rows
shape(2) = -3;
shape(3) = num_cols
call c_f_pointer(cPtr, myArrayPtr, shape(1:3:2))
do j = 1, num_cols
do i = 1, num_rows
if(myArrayPtr(i,j) /= ((j-1)*num_rows)+(i-1)) call abort ()
end do
end do
end subroutine test_long_long_2d
subroutine test_long_1d(cPtr, num_elems) bind(c)
use, intrinsic :: iso_c_binding
type(c_ptr), value :: cPtr
integer(c_int), value :: num_elems
integer, dimension(:), pointer :: myArrayPtr
integer(c_long), dimension(1) :: shape
integer :: i
shape(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_long_1d
subroutine test_int_1d(cPtr, num_elems) bind(c)
use, intrinsic :: iso_c_binding
type(c_ptr), value :: cPtr
integer(c_int), value :: num_elems
integer, dimension(:), pointer :: myArrayPtr
integer(c_int), dimension(1) :: shape
integer :: i
shape(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_int_1d
subroutine test_short_1d(cPtr, num_elems) bind(c)
use, intrinsic :: iso_c_binding
type(c_ptr), value :: cPtr
integer(c_int), value :: num_elems
integer, dimension(:), pointer :: myArrayPtr
integer(c_short), dimension(1) :: shape
integer :: i
shape(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_short_1d
subroutine test_mixed(cPtr, num_elems) bind(c)
use, intrinsic :: iso_c_binding
type(c_ptr), value :: cPtr
integer(c_int), value :: num_elems
integer, dimension(:), pointer :: myArrayPtr
integer(c_int), dimension(1) :: shape1
integer(c_long_long), dimension(1) :: shape2
integer :: i
shape1(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape1)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
nullify(myArrayPtr)
shape2(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape2)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_mixed
end module c_f_pointer_shape_tests_4
! { dg-final { cleanup-modules "c_f_pointer_shape_tests_4" } }

46
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c Normal file
View File

@ -0,0 +1,46 @@
#define NUM_ELEMS 10
#define NUM_ROWS 2
#define NUM_COLS 3
void test_long_long_1d(int *array, int num_elems);
void test_long_long_2d(int *array, int num_rows, int num_cols);
void test_long_1d(int *array, int num_elems);
void test_int_1d(int *array, int num_elems);
void test_short_1d(int *array, int num_elems);
void test_mixed(int *array, int num_elems);
int main(int argc, char **argv)
{
int my_array[NUM_ELEMS];
int my_2d_array[NUM_ROWS][NUM_COLS];
int i, j;
for(i = 0; i < NUM_ELEMS; i++)
my_array[i] = i;
for(i = 0; i < NUM_ROWS; i++)
for(j = 0; j < NUM_COLS; j++)
my_2d_array[i][j] = (i*NUM_COLS) + j;
/* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */
test_long_long_1d(my_array, NUM_ELEMS);
/* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long.
The indices are transposed for Fortran. */
test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS);
/* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */
test_long_1d(my_array, NUM_ELEMS);
/* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */
test_int_1d(my_array, NUM_ELEMS);
/* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */
test_short_1d(my_array, NUM_ELEMS);
/* Test c_f_pointer where SHAPE is of type integer, kind=c_int and
kind=c_long_long. */
test_mixed(my_array, NUM_ELEMS);
return 0;
}

6
libgfortran/ChangeLog
View File

@ -1,3 +1,9 @@
2009-05-27 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/40187
* intrinsics/iso_c_binding.c (c_f_pointer_u0): Take care
of stride in "shape" argument.
2009-05-26 Tobias Burnus <burnus@net-b.de>
PR fortran/39178

60
libgfortran/intrinsics/iso_c_binding.c
View File

@ -95,9 +95,17 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
if (shape != NULL)
{
index_type source_stride;
index_type size;
char *p;
f_ptr_out->offset = 0;
shapeSize = 0;
p = shape->data;
size = GFC_DESCRIPTOR_SIZE(shape);
source_stride = shape->dim[0].stride * size;
/* shape's length (rank of the output array) */
shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound;
for (i = 0; i < shapeSize; i++)
@ -107,40 +115,40 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
/* Have to allow for the SHAPE array to be any valid kind for
an INTEGER type. */
#ifdef HAVE_GFC_INTEGER_1
if (GFC_DESCRIPTOR_SIZE (shape) == 1)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_1 *) (shape->data))[i];
if (size == 1)
f_ptr_out->dim[i].ubound = *((GFC_INTEGER_1 *) p);
#endif
#ifdef HAVE_GFC_INTEGER_2
if (GFC_DESCRIPTOR_SIZE (shape) == 2)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_2 *) (shape->data))[i];
if (size == 2)
f_ptr_out->dim[i].ubound = *((GFC_INTEGER_2 *) p);
#endif
#ifdef HAVE_GFC_INTEGER_4
if (GFC_DESCRIPTOR_SIZE (shape) == 4)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_4 *) (shape->data))[i];
if (size == 4)
f_ptr_out->dim[i].ubound = *((GFC_INTEGER_4 *) p);
#endif
#ifdef HAVE_GFC_INTEGER_8
if (GFC_DESCRIPTOR_SIZE (shape) == 8)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_8 *) (shape->data))[i];
if (size == 8)
f_ptr_out->dim[i].ubound = *((GFC_INTEGER_8 *) p);
#endif
#ifdef HAVE_GFC_INTEGER_16
if (GFC_DESCRIPTOR_SIZE (shape) == 16)
f_ptr_out->dim[i].ubound = ((GFC_INTEGER_16 *) (shape->data))[i];
#endif
}
if (size == 16)
f_ptr_out->dim[i].ubound = *((GFC_INTEGER_16 *) p);
#endif
p += source_stride;
/* Set the offset and strides.
offset is (sum of (dim[i].lbound * dim[i].stride) for all
dims) the -1 means we'll back the data pointer up that much
perhaps we could just realign the data pointer and not change
the offset? */
f_ptr_out->dim[0].stride = 1;
f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride;
for (i = 1; i < shapeSize; i++)
{
f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1)
- f_ptr_out->dim[i-1].lbound;
f_ptr_out->offset += f_ptr_out->dim[i].lbound
* f_ptr_out->dim[i].stride;
if (i == 0)
{
f_ptr_out->dim[0].stride = 1;
f_ptr_out->offset = f_ptr_out->dim[0].lbound
* f_ptr_out->dim[0].stride;
}
else
{
f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1)
- f_ptr_out->dim[i-1].lbound;
f_ptr_out->offset += f_ptr_out->dim[i].lbound
* f_ptr_out->dim[i].stride;
}
}
f_ptr_out->offset *= -1;