2013-05-20 Tobias Burnus <burnus@net-b.de>
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 <burnus@net-b.de>
+
+ PR fortran/48858
* decl.c (gfc_match_bind_c_stmt): Add gfc_notify_std.
* match.c (gfc_match_common): Don't add commons to gsym.
* resolve.c (resolve_common_blocks): Add to gsym and
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;
}
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;
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;
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)
{
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)
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);
}
/* 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;
+ }
}
}
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);
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);
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);
/* 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
2013-05-20 Tobias Burnus <burnus@net-b.de>
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 <burnus@net-b.de>
+
+ PR fortran/48858
* gfortran.dg/test_common_binding_labels.f03: Update dg-error.
* gfortran.dg/test_common_binding_labels_2_main.f03: Ditto.
* gfortran.dg/test_common_binding_labels_3_main.f03: Ditto.
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { dg-do compile }
+!
+! PR fortran/48858
+!
+subroutine foo() bind(C,name="bar")
+end subroutine foo
+
+subroutine foo() bind(C,name="sub")
+end subroutine foo
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
projects / platform / upstream / gcc.git / commitdiff