From 4f099a038c1ce00ab8781789ec2d5b50d2b1ad84 Mon Sep 17 00:00:00 2001 From: tkoenig Date: Wed, 27 May 2009 05:27:31 +0000 Subject: [PATCH] 2009-05-27 Thomas Koenig PR libfortran/40187 * intrinsics/iso_c_binding.c (c_f_pointer_u0): Take care of stride in "shape" argument. 2009-05-27 Thomas Koenig 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@147894 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/testsuite/ChangeLog | 6 ++ .../gfortran.dg/c_f_pointer_shape_tests_4.f03 | 115 +++++++++++++++++++++ .../gfortran.dg/c_f_pointer_shape_tests_4_driver.c | 46 +++++++++ libgfortran/ChangeLog | 6 ++ libgfortran/intrinsics/iso_c_binding.c | 62 ++++++----- 5 files changed, 208 insertions(+), 27 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f42781b..3c08129 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-05-27 Thomas Koenig + + 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 PR fortran/40246 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 new file mode 100644 index 0000000..89b8666 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 @@ -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" } } + diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c new file mode 100644 index 0000000..1282beb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c @@ -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; +} diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index e651606..d4a34c5 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2009-05-27 Thomas Koenig + + PR libfortran/40187 + * intrinsics/iso_c_binding.c (c_f_pointer_u0): Take care + of stride in "shape" argument. + 2009-05-26 Tobias Burnus PR fortran/39178 diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c index a8d8768..38f0775 100644 --- a/libgfortran/intrinsics/iso_c_binding.c +++ b/libgfortran/intrinsics/iso_c_binding.c @@ -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 - } - - /* 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 (size == 16) + f_ptr_out->dim[i].ubound = *((GFC_INTEGER_16 *) p); +#endif + p += source_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; -- 2.7.4