2007-08-22 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-22  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.
	* gfortran.dg/c_f_pointer_shape_tests_3.f03: New test case.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127719 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 346e811..ae7145d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2007-08-22  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-22  Janus Weil  <jaydub66@gmail.com>
 
        * decl.c (match_attr_spec): Pass on errors from gfc_match_bind_c.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ae15d16..fbb7a03 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2351,11 +2351,6 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
      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))
     {
@@ -2396,13 +2391,6 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
          /* 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;
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cf9b7ed..7ee7695 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2007-08-22  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.
+       * gfortran.dg/c_f_pointer_shape_tests_3.f03: New test case. 
+
 2007-08-22  Janus Weil  <jaydub66@gmail.com>
 
        * interface_abstract_1.f90: Extended test case.

diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
index 5d6acc2..6629089 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
@@ -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" } } 
 

diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
index 686ae8f..1282beb 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
@@ -7,6 +7,7 @@ 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)
 {
@@ -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;
 }

diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
new file mode 100644 (file)
index 0000000..31fd938
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! Verify that the type and rank of the SHAPE argument are enforced.
+module c_f_pointer_shape_tests_3
+  use, intrinsic :: iso_c_binding
+  
+contains
+  subroutine sub0(my_c_array) bind(c)
+    type(c_ptr), value :: my_c_array
+    integer(c_int), dimension(:), pointer :: my_array_ptr
+    
+    call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be a rank 1 INTEGER array" }
+  end subroutine sub0
+
+  subroutine sub1(my_c_array) bind(c)
+    type(c_ptr), value :: my_c_array
+    integer(c_int), dimension(:), pointer :: my_array_ptr
+    integer(c_int), dimension(1,1) :: shape
+
+    shape(1,1) = 10
+    call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be a rank 1 INTEGER array" }
+  end subroutine sub1
+end module c_f_pointer_shape_tests_3