[patch, libfortran] Fix PR 40187

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

this fixes PR 40187, where we didn't use strides in the "shape" argument
to c_f_pointer.

Regression-tested on trunk, on i686-pc-linux-gnu.  OK for trunk and
fortran-dev?

	Thomas

2009-05-23  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.

Index: intrinsics/iso_c_binding.c
===================================================================
--- intrinsics/iso_c_binding.c	(revision 147775)
+++ intrinsics/iso_c_binding.c	(working copy)
@@ -95,9 +95,17 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (v
 
   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) (v
           /* 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;

Attachment: c_f_pointer_shape_tests_4.f03
Description: Text document

#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;
}