From: Tobias Burnus Date: Mon, 20 May 2013 20:05:40 +0000 (+0200) Subject: re PR fortran/48858 (Incorrect error for same binding label on two generic interface... X-Git-Tag: releases/gcc-4.9.0~5796 X-Git-Url: https://gcc.gnu.org/git/?a=commitdiff_plain;h=f11de7c5f898a5a613f7ccb47f999312f505f125;p=gcc.git re PR fortran/48858 (Incorrect error for same binding label on two generic interface specifics) 2013-05-20 Tobias Burnus PR fortran/48858 * decl.c (add_global_entry): Use nonbinding name only for F2003 or if no binding label exists. (gfc_match_entry): Update calls. * parse.c (gfc_global_used): Improve error message. (add_global_procedure): Use nonbinding name only for F2003 or if no binding label exists. (gfc_parse_file): Update call. * resolve.c (resolve_global_procedure): Use binding name when available. * trans-decl.c (gfc_get_extern_function_decl): Ditto. 2013-05-20 Tobias Burnus PR fortran/48858 * gfortran.dg/binding_label_tests_17.f90: New. * gfortran.dg/binding_label_tests_18.f90: New. * gfortran.dg/binding_label_tests_19.f90: New. * gfortran.dg/binding_label_tests_20.f90: New. * gfortran.dg/binding_label_tests_21.f90: New. * gfortran.dg/binding_label_tests_22.f90: New. * gfortran.dg/binding_label_tests_23.f90: New. From-SVN: r199119 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fca9761697b1..08b4602dd86a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2013-05-20 Tobias Burnus + + PR fortran/48858 + * decl.c (add_global_entry): Use nonbinding name + only for F2003 or if no binding label exists. + (gfc_match_entry): Update calls. + * parse.c (gfc_global_used): Improve error message. + (add_global_procedure): Use nonbinding name + only for F2003 or if no binding label exists. + (gfc_parse_file): Update call. + * resolve.c (resolve_global_procedure): Use binding + name when available. + * trans-decl.c (gfc_get_extern_function_decl): Ditto. + 2013-05-20 Tobias Burnus PR fortran/48858 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 06a049c6fdd5..cb449a2f7a67 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -5354,27 +5354,56 @@ cleanup: to return false upon finding an existing global entry. */ static bool -add_global_entry (const char *name, int sub) +add_global_entry (const char *name, const char *binding_label, bool sub) { gfc_gsymbol *s; enum gfc_symbol_type type; - s = gfc_get_gsymbol(name); type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - if (s->defined - || (s->type != GSYM_UNKNOWN - && s->type != type)) - gfc_global_used(s, NULL); - else + /* Only in Fortran 2003: For procedures with a binding label also the Fortran + name is a global identifier. */ + if (!binding_label || gfc_notification_std (GFC_STD_F2008)) { - s->type = type; - s->where = gfc_current_locus; - s->defined = 1; - s->ns = gfc_current_ns; - return true; + s = gfc_get_gsymbol (name); + + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) + { + gfc_global_used(s, NULL); + return false; + } + else + { + s->type = type; + s->where = gfc_current_locus; + s->defined = 1; + s->ns = gfc_current_ns; + } } - return false; + + /* Don't add the symbol multiple times. */ + if (binding_label + && (!gfc_notification_std (GFC_STD_F2008) + || strcmp (name, binding_label) != 0)) + { + s = gfc_get_gsymbol (binding_label); + + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) + { + gfc_global_used(s, NULL); + return false; + } + else + { + s->type = type; + s->binding_label = binding_label; + s->where = gfc_current_locus; + s->defined = 1; + s->ns = gfc_current_ns; + } + } + + return true; } @@ -5502,10 +5531,6 @@ gfc_match_entry (void) if (state == COMP_SUBROUTINE) { - /* An entry in a subroutine. */ - if (!gfc_current_ns->parent && !add_global_entry (name, 1)) - return MATCH_ERROR; - m = gfc_match_formal_arglist (entry, 0, 1); if (m != MATCH_YES) return MATCH_ERROR; @@ -5527,6 +5552,11 @@ gfc_match_entry (void) return MATCH_ERROR; } + if (!gfc_current_ns->parent + && !add_global_entry (name, entry->binding_label, true)) + return MATCH_ERROR; + + /* An entry in a subroutine. */ if (!gfc_add_entry (&entry->attr, entry->name, NULL) || !gfc_add_subroutine (&entry->attr, entry->name, NULL)) return MATCH_ERROR; @@ -5542,9 +5572,6 @@ gfc_match_entry (void) ENTRY f() RESULT (r) can't be written as ENTRY f RESULT (r). */ - if (!gfc_current_ns->parent && !add_global_entry (name, 0)) - return MATCH_ERROR; - old_loc = gfc_current_locus; if (gfc_match_eos () == MATCH_YES) { @@ -5593,6 +5620,10 @@ gfc_match_entry (void) entry->result = entry; } } + + if (!gfc_current_ns->parent + && !add_global_entry (name, entry->binding_label, false)) + return MATCH_ERROR; } if (gfc_match_eos () != MATCH_YES) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 83011138ea59..ba1730a8f184 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -4232,8 +4232,12 @@ gfc_global_used (gfc_gsymbol *sym, locus *where) name = NULL; } - gfc_error("Global name '%s' at %L is already being used as a %s at %L", - sym->name, where, name, &sym->where); + if (sym->binding_label) + gfc_error ("Global binding name '%s' at %L is already being used as a %s " + "at %L", sym->binding_label, where, name, &sym->where); + else + gfc_error ("Global name '%s' at %L is already being used as a %s at %L", + sym->name, where, name, &sym->where); } @@ -4342,22 +4346,48 @@ loop: /* Add a procedure name to the global symbol table. */ static void -add_global_procedure (int sub) +add_global_procedure (bool sub) { gfc_gsymbol *s; - s = gfc_get_gsymbol(gfc_new_block->name); + /* Only in Fortran 2003: For procedures with a binding label also the Fortran + name is a global identifier. */ + if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008)) + { + s = gfc_get_gsymbol (gfc_new_block->name); - if (s->defined - || (s->type != GSYM_UNKNOWN - && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) - gfc_global_used(s, NULL); - else + if (s->defined + || (s->type != GSYM_UNKNOWN + && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + gfc_global_used(s, NULL); + else + { + s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + s->where = gfc_current_locus; + s->defined = 1; + s->ns = gfc_current_ns; + } + } + + /* Don't add the symbol multiple times. */ + if (gfc_new_block->binding_label + && (!gfc_notification_std (GFC_STD_F2008) + || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0)) { - s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - s->where = gfc_current_locus; - s->defined = 1; - s->ns = gfc_current_ns; + s = gfc_get_gsymbol (gfc_new_block->binding_label); + + if (s->defined + || (s->type != GSYM_UNKNOWN + && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + gfc_global_used(s, NULL); + else + { + s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + s->binding_label = gfc_new_block->binding_label; + s->where = gfc_current_locus; + s->defined = 1; + s->ns = gfc_current_ns; + } } } @@ -4556,7 +4586,7 @@ loop: break; case ST_SUBROUTINE: - add_global_procedure (1); + add_global_procedure (true); push_state (&s, COMP_SUBROUTINE, gfc_new_block); accept_statement (st); parse_progunit (ST_NONE); @@ -4564,7 +4594,7 @@ loop: break; case ST_FUNCTION: - add_global_procedure (0); + add_global_procedure (false); push_state (&s, COMP_FUNCTION, gfc_new_block); accept_statement (st); parse_progunit (ST_NONE); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 06fa3018f4c3..f3607b417742 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2333,7 +2333,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - gsym = gfc_get_gsymbol (sym->name); + gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name); if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) gfc_global_used (gsym, where); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4c0b1da5af14..795057b9928e 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1643,7 +1643,8 @@ gfc_get_extern_function_decl (gfc_symbol * sym) /* See if this is an external procedure from the same file. If so, return the backend_decl. */ - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label + ? sym->binding_label : sym->name); if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL) && !sym->backend_decl diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a86119337157..d6b531c5709a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2013-05-20 Tobias Burnus + + PR fortran/48858 + * gfortran.dg/binding_label_tests_17.f90: New. + * gfortran.dg/binding_label_tests_18.f90: New. + * gfortran.dg/binding_label_tests_19.f90: New. + * gfortran.dg/binding_label_tests_20.f90: New. + * gfortran.dg/binding_label_tests_21.f90: New. + * gfortran.dg/binding_label_tests_22.f90: New. + * gfortran.dg/binding_label_tests_23.f90: New. + 2013-05-20 Tobias Burnus PR fortran/48858 diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_17.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_17.f90 new file mode 100644 index 000000000000..4243ffbdb1ea --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_17.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + +subroutine sub() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine sub + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_18.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_18.f90 new file mode 100644 index 000000000000..548d367e3d25 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_18.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + +subroutine foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_19.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_19.f90 new file mode 100644 index 000000000000..a6f63e685882 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_19.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() bind(C,name="bar") +end subroutine foo + +subroutine foo() bind(C,name="sub") +end subroutine foo + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_20.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_20.f90 new file mode 100644 index 000000000000..2b0da4316978 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_20.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/48858 +! +subroutine foo() bind(C,name="bar") ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + +subroutine foo() bind(C,name="sub") ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_21.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_21.f90 new file mode 100644 index 000000000000..0519d0f1d2de --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_21.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +entry sub() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_22.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_22.f90 new file mode 100644 index 000000000000..b136754d5931 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_22.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +entry foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_23.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_23.f90 new file mode 100644 index 000000000000..ba9e61550f4d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_23.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! PR fortran/48858 +! +integer function foo(x) + integer :: x + call abort() + foo = 99 +end function foo + +integer function other() bind(C, name="bar") + other = 42 +end function other + +program test + interface + integer function foo() bind(C, name="bar") + end function foo + end interface + if (foo() /= 42) call abort() ! Ensure that the binding name is all what counts +end program test