OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/48858 (Incorrect error for same binding label on two generic interface specifics)

Browse Source 
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
        * 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
This commit is contained in:
Tobias Burnus 2013-05-20 22:05:40 +02:00 committed by Tobias Burnus
parent 878cdb7b38
commit f11de7c5f8
13 changed files with 203 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
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

71
gcc/fortran/decl.c
View File

@ -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)

62
gcc/fortran/parse.c
View File

@ -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);
if (s->defined
|| (s->type != GSYM_UNKNOWN
&& s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
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 (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
{
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->name);
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 = 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);

2
gcc/fortran/resolve.c
View File

@ -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);

3
gcc/fortran/trans-decl.c
View File

@ -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

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
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

10
gcc/testsuite/gfortran.dg/binding_label_tests_17.f90 Normal file
View File

@ -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

10
gcc/testsuite/gfortran.dg/binding_label_tests_18.f90 Normal file
View File

@ -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

10
gcc/testsuite/gfortran.dg/binding_label_tests_19.f90 Normal file
View File

@ -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

11
gcc/testsuite/gfortran.dg/binding_label_tests_20.f90 Normal file
View File

@ -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

8
gcc/testsuite/gfortran.dg/binding_label_tests_21.f90 Normal file
View File

@ -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

8
gcc/testsuite/gfortran.dg/binding_label_tests_22.f90 Normal file
View File

@ -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

21
gcc/testsuite/gfortran.dg/binding_label_tests_23.f90 Normal file
View File

@ -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