From: Tobias Burnus Date: Tue, 31 Jul 2012 10:06:24 +0000 (+0200) Subject: interface.c (gfc_procedure_use): Return gfc_try instead of X-Git-Tag: releases/gcc-4.8.0~4202 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=f8552cd47a3d3e7560efafb21c7aecebf33c08df;p=thirdparty%2Fgcc.git interface.c (gfc_procedure_use): Return gfc_try instead of 2012-07-31 Tobias Burnus * interface.c (gfc_procedure_use): Return gfc_try instead of * void. * gfortran.h (gfc_procedure_use): Update prototype. * resolve.c (gfc_iso_c_func_interface): Allow noninteroperable procedures for c_funloc for TS29113. * (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer. 2012-07-31 Tobias Burnus * gfortran.dg/c_funloc_tests_6.f90: New. * gfortran.dg/c_funloc_tests_7.f90: New. * gfortran.dg/c_funloc_tests_5.f03: Compile with -std=f2003. From-SVN: r190003 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4974cb34d6b4..fcd07f1b59ec 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2012-07-31 Tobias Burnus + + * interface.c (gfc_procedure_use): Return gfc_try instead of void. + * gfortran.h (gfc_procedure_use): Update prototype. + * resolve.c (gfc_iso_c_func_interface): Allow noninteroperable + procedures for c_funloc for TS29113. + * (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add + diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer. + 2012-07-30 Janus Weil PR fortran/51081 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 063959a8df98..8fea23da1c3b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2849,7 +2849,7 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *); int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int, char *, int, const char *, const char *); void gfc_check_interfaces (gfc_namespace *); -void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); +gfc_try gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *); gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_actual_arglist **); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 098ec3d26b5f..0f8951cd7c47 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2927,7 +2927,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) well, the actual argument list will also end up being properly sorted. */ -void +gfc_try gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { /* Warn about calls with an implicit interface. Special case @@ -2954,7 +2954,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error("The pointer object '%s' at %L must have an explicit " "function interface or be declared as array", sym->name, where); - return; + return FAILURE; } if (sym->attr.allocatable && !sym->attr.external) @@ -2962,14 +2962,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error("The allocatable object '%s' at %L must have an explicit " "function interface or be declared as array", sym->name, where); - return; + return FAILURE; } if (sym->attr.allocatable) { gfc_error("Allocatable function '%s' at %L must have an explicit " "function interface", sym->name, where); - return; + return FAILURE; } for (a = *ap; a; a = a->next) @@ -3009,7 +3009,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) && a->expr->ts.type == BT_UNKNOWN) { gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); - return; + return FAILURE; } /* TS 29113, C407b. */ @@ -3018,19 +3018,23 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { gfc_error ("Assumed-rank argument requires an explicit interface " "at %L", &a->expr->where); - return; + return FAILURE; } } - return; + return SUCCESS; } if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where)) - return; + return FAILURE; + + if (check_intents (sym->formal, *ap) == FAILURE) + return FAILURE; - check_intents (sym->formal, *ap); if (gfc_option.warn_aliasing) check_some_aliasing (sym->formal, *ap); + + return SUCCESS; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 25c6c8ec00d6..dcce3f56ce1f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3011,20 +3011,18 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { /* TODO: Update this error message to allow for procedure pointers once they are implemented. */ - gfc_error_now ("Parameter '%s' to '%s' at %L must be a " + gfc_error_now ("Argument '%s' to '%s' at %L must be a " "procedure", args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } - else if (args_sym->attr.is_bind_c != 1) - { - gfc_error_now ("Parameter '%s' to '%s' at %L must be " - "BIND(C)", - args_sym->name, sym->name, - &(args->expr->where)); - retval = FAILURE; - } + else if (args_sym->attr.is_bind_c != 1 + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "argument '%s' to '%s' at %L", + args_sym->name, sym->name, + &(args->expr->where)) == FAILURE) + retval = FAILURE; } /* for c_loc/c_funloc, the new symbol is the same as the old one */ @@ -3479,7 +3477,11 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) /* Make sure the actual arguments are in the necessary order (based on the formal args) before resolving. */ - gfc_procedure_use (sym, &c->ext.actual, &(c->loc)); + if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE) + { + c->resolved_sym = sym; + return MATCH_ERROR; + } if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) || (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) @@ -3490,6 +3492,15 @@ 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_error ("Argument at %L to C_F_POINTER shall have the type" + " C_PTR", &c->ext.actual->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 correct since we short-circuit this check in @@ -3515,7 +3526,26 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) } } } - + else /* ISOCBINDING_F_PROCPOINTER. */ + { + if (c->ext.actual + && (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_FUNPTR)) + { + gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type " + "C_FUNPTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + if (c->ext.actual && c->ext.actual->next + && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "procedure-pointer at %L to C_F_FUNPOINTER", + &c->ext.actual->next->expr->where) + == FAILURE) + m = MATCH_ERROR; + } + if (m != MATCH_ERROR) { /* the 1 means to add the optional arg to formal list */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2802689c361b..b02534c080fb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-07-31 Tobias Burnus + + * gfortran.dg/c_funloc_tests_6.f90: New. + * gfortran.dg/c_funloc_tests_7.f90: New. + * gfortran.dg/c_funloc_tests_5.f03: Compile with -std=f2003. + 2012-07-31 Paolo Carlini PR c++/53624 diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 index bbb418de6297..f3fdb2b6f645 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=f2003" } ! Test that the arg checking for c_funloc verifies the procedures are ! C interoperable. module c_funloc_tests_5 @@ -7,9 +8,9 @@ contains subroutine sub0() bind(c) type(c_funptr) :: my_c_funptr - my_c_funptr = c_funloc(sub1) ! { dg-error "must be BIND.C." } + my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable argument" } - my_c_funptr = c_funloc(func0) ! { dg-error "must be BIND.C." } + my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable argument" } end subroutine sub0 subroutine sub1() diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 new file mode 100644 index 000000000000..e09b0bb375ad --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Check relaxed TS29113 constraints for procedures +! and c_f_*pointer argument checking for c_ptr/c_funptr. +! + +use iso_c_binding +implicit none +type(c_ptr) :: cp +type(c_funptr) :: cfp + +interface + subroutine sub() bind(C) + end subroutine sub +end interface +integer(c_int), pointer :: int +procedure(sub), pointer :: fsub + +integer, external :: noCsub +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_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'" } +call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure-pointer at .1. to C_F_FUNPOINTER" } +end diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_7.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_7.f90 new file mode 100644 index 000000000000..8e51c892cbda --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_7.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts -fdump-tree-original" } +! +! Check relaxed TS29113 constraints for procedures +! and c_f_*pointer argument checking for c_ptr/c_funptr. +! + +use iso_c_binding +implicit none +type(c_funptr) :: cfp + +integer, external :: noCsub +procedure(integer), pointer :: fint + +cfp = c_funloc (noCsub) +call c_f_procpointer (cfp, fint) +end + +! { dg-final { scan-tree-dump-times "cfp =\[^;\]+ nocsub;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fint =\[^;\]+ cfp;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } +