From fd54f19ccbe7d82f2b33c7a6bbaf7d7de1cbb5c5 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 22 Aug 2007 21:28:08 +0000 Subject: [PATCH] 2007-08-22 Christopher D. Rickett 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 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 --- gcc/fortran/ChangeLog | 6 ++++++ gcc/fortran/resolve.c | 12 ----------- gcc/testsuite/ChangeLog | 9 +++++++++ .../gfortran.dg/c_f_pointer_shape_tests_2.f03 | 23 ++++++++++++++++++++++ .../gfortran.dg/c_f_pointer_shape_tests_2_driver.c | 7 ++++++- .../gfortran.dg/c_f_pointer_shape_tests_3.f03 | 22 +++++++++++++++++++++ 6 files changed, 66 insertions(+), 13 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 346e811..ae7145d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2007-08-22 Christopher D. Rickett + + 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 * 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 --- 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 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2007-08-22 Christopher D. Rickett + + 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 * 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 --- 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 --- 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 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 -- 2.7.4