[PATCH,fortran]: proposed fix for PR 33020

[Christopher D. Rickett]

hi all,

the attached patch fixes PR 33020.  currently, the kind of the SHAPE 
parameter to c_f_pointer is set once the actual is seen.  however, this 
can prevent shape arguments of different kinds being used for different 
calls within the same namespace.  the SHAPE parameter should not be set 
because it needs to allow any valid integer kind.

bootstrapped and regtested on x86 linux with no new failures.

Chris

:ADDPATCH fortran:

ChangeLog entry:

2007-08-09  Christopher D. Rickett  <crickett@lanl.gov>

 	PR fortran/33020
 	* resolve.c (gfc_iso_c_sub_interface): Remove setting of type and
 	kind for optional SHAPE parameter of C_F_POINTER.

2007-08-09  Christopher D. Rickett  <crickett@lanl.gov>

 	PR fortran/33020
 	* gfortran.dg/c_f_pointer_shape_tests_2.f03: Update test to
 	include multiple kinds for SHAPE parameter within a single
 	namespace.
 	* gfortran.dg/c_f_pointer_shape_tests_2_driver.c: Ditto.
-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c	(revision 127182)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c	(working copy)
@@ -7,6 +7,7 @@ void test_long_long_2d(int *array, int n
 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)
 {
@@ -36,6 +37,10 @@ int main(int argc, char **argv)
 
   /* 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;
 }
Index: gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03	(revision 127182)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03	(working copy)
@@ -86,6 +86,29 @@ contains
        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_2
 ! { dg-final { cleanup-modules "c_f_pointer_shape_tests_2" } } 
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 127182)
+++ gcc/fortran/resolve.c	(working copy)
@@ -2344,11 +2344,6 @@ gfc_iso_c_sub_interface (gfc_code *c, gf
      formal args) before resolving.  */
   gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
 
-  /* Give the optional SHAPE formal arg a type now that we've done our
-     initial checking against the actual.  */
-  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
-    sym->formal->next->next->sym->ts.type = BT_INTEGER;
-
   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
     {
@@ -2389,13 +2384,6 @@ gfc_iso_c_sub_interface (gfc_code *c, gf
 	  /* the 1 means to add the optional arg to formal list */
 	  new_sym = get_iso_c_sym (sym, name, binding_label, 1);
 	 
-	  /* Set the kind for the SHAPE array to that of the actual
-	     (if given).  */
-	  if (c->ext.actual != NULL && c->ext.actual->next != NULL
-	      && c->ext.actual->next->expr->rank != 0)
-	    new_sym->formal->next->next->sym->ts.kind =
-	      c->ext.actual->next->next->expr->ts.kind;
-	 
 	  /* for error reporting, say it's declared where the original was */
 	  new_sym->declared_at = sym->declared_at;
 	}