From: Janus Weil Date: Sun, 30 Sep 2012 16:36:02 +0000 (+0200) Subject: re PR fortran/54667 ([OOP] gimplification failure with c_f_pointer) X-Git-Tag: misc/gccgo-go1_1_2~556 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=1b04be5d4a6109d44b54ad398da63623db9dab94;p=thirdparty%2Fgcc.git re PR fortran/54667 ([OOP] gimplification failure with c_f_pointer) 2012-09-30 Janus Weil PR fortran/54667 * intrinsic.texi (C_F_POINTER): Fix description. * resolve.c (gfc_iso_c_sub_interface): Add a check for FPTR argument of C_F_POINTER. Modify two error messages. Cleanup. 2012-09-30 Janus Weil PR fortran/54667 * gfortran.dg/c_funloc_tests_6.f90: Modified error message. * gfortran.dg/c_f_pointer_shape_test.f90: Ditto. * gfortran.dg/c_f_pointer_tests_5.f90: New. From-SVN: r191870 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 533878768d0c..e1cb45affb1e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2012-09-30 Janus Weil + + PR fortran/54667 + * intrinsic.texi (C_F_POINTER): Fix description. + * resolve.c (gfc_iso_c_sub_interface): Add a check for FPTR argument + of C_F_POINTER. Modify two error messages. Cleanup. + 2012-09-24 Tobias Burnus PR fortran/54618 diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 47a9feed68c1..a8ec1ed76b4f 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -2362,9 +2362,8 @@ end program main @table @asis @item @emph{Description}: -@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} Assign the target the C pointer -@var{CPTR} to the Fortran pointer @var{FPTR} and specify its -shape. +@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} assigns the target of the C pointer +@var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape. @item @emph{Standard}: Fortran 2003 and later diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0a20540b6da7..3e23ca2e3112 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3532,36 +3532,45 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) { if (c->ext.actual != NULL && c->ext.actual->next != NULL) { - if (c->ext.actual->expr->ts.type != BT_DERIVED - || c->ext.actual->expr->ts.u.derived->intmod_sym_id - != ISOCBINDING_PTR) + gfc_actual_arglist *arg1 = c->ext.actual; + gfc_actual_arglist *arg2 = c->ext.actual->next; + gfc_actual_arglist *arg3 = c->ext.actual->next->next; + + /* Check first argument (CPTR). */ + if (arg1->expr->ts.type != BT_DERIVED + || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR) + { + gfc_error ("Argument CPTR to C_F_POINTER at %L shall have " + "the type C_PTR", &arg1->expr->where); + m = MATCH_ERROR; + } + + /* Check second argument (FPTR). */ + if (arg2->expr->ts.type == BT_CLASS) { - gfc_error ("Argument at %L to C_F_POINTER shall have the type" - " C_PTR", &c->ext.actual->expr->where); + gfc_error ("Argument FPTR to C_F_POINTER at %L must not be " + "polymorphic", &arg2->expr->where); m = MATCH_ERROR; } - /* Make sure we got a third arg if the second arg has non-zero - rank. We must also check that the type and rank are + /* Make sure we got a third arg (SHAPE) if the second arg has + non-zero rank. We must also check that the type and rank are correct since we short-circuit this check in gfc_procedure_use() (called above to sort actual args). */ - if (c->ext.actual->next->expr->rank != 0) + if (arg2->expr->rank != 0) { - if(c->ext.actual->next->next == NULL - || c->ext.actual->next->next->expr == NULL) + if (arg3 == NULL || arg3->expr == NULL) { m = MATCH_ERROR; - gfc_error ("Missing SHAPE parameter for call to %s " - "at %L", sym->name, &(c->loc)); + gfc_error ("Missing SHAPE argument for call to %s at %L", + sym->name, &c->loc); } - else if (c->ext.actual->next->next->expr->ts.type - != BT_INTEGER - || c->ext.actual->next->next->expr->rank != 1) + else if (arg3->expr->ts.type != BT_INTEGER + || arg3->expr->rank != 1) { m = MATCH_ERROR; - gfc_error ("SHAPE parameter for call to %s at %L must " - "be a rank 1 INTEGER array", sym->name, - &(c->loc)); + gfc_error ("SHAPE argument for call to %s at %L must be " + "a rank 1 INTEGER array", sym->name, &c->loc); } } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2934e0ad14b0..9acf70eb5edc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-09-30 Janus Weil + + PR fortran/54667 + * gfortran.dg/c_funloc_tests_6.f90: Modified error message. + * gfortran.dg/c_f_pointer_shape_test.f90: Ditto. + * gfortran.dg/c_f_pointer_tests_5.f90: New. + 2012-09-30 Janus Weil * gfortran.dg/allocate_derived_1.f90: Re-enable class array checks, diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 index c6204bdac7f6..f27730a431d3 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } -! verify that the compiler catches the error in the call to c_f_pointer -! because it is missing the required SHAPE parameter. the SHAPE parameter -! is optional, in general, but must exist if given a fortran pointer +! Verify that the compiler catches the error in the call to c_f_pointer +! because it is missing the required SHAPE argument. The SHAPE argument +! is optional, in general, but must exist if given a Fortran pointer ! to a non-zero rank object. --Rickett, 09.26.06 module c_f_pointer_shape_test contains @@ -13,7 +13,8 @@ contains type(c_ptr), value :: cPtr myArrayPtr => myArray - call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE parameter" } + call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE argument" } end subroutine test_0 end module c_f_pointer_shape_test +! { dg-final { cleanup-modules "c_f_pointer_shape_test" } } diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 new file mode 100644 index 000000000000..05a3d8b85488 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR 54667: [OOP] gimplification failure with c_f_pointer +! +! Contributed by Andrew Benson + +use, intrinsic :: ISO_C_Binding +type :: nc +end type +type(c_ptr) :: cSelf +class(nc), pointer :: self +call c_f_pointer(cSelf, self) ! { dg-error "must not be polymorphic" } +end diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 index e09b0bb375ad..13ca9d91d9e3 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 @@ -23,7 +23,7 @@ procedure(integer), pointer :: fint cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." }) cfp = c_loc (int) ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." } -call c_f_pointer (cfp, int) ! { dg-error "Argument at .1. to C_F_POINTER shall have the type C_PTR" } +call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR to C_F_POINTER at .1. shall have the type C_PTR" } call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" } cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" }