--- /dev/null
+! { 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" } }
+
--- /dev/null
+#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;
+}
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++)
/* 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;