Skip to content

R
riscv-gcc-1
Commit 77f8682b by Tobias Burnus Committed by Tobias Burnus
Options

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

2013-05-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48858
        PR fortran/55465
        * decl.c (add_global_entry): Add sym_name.
        * parse.c (add_global_procedure): Ditto.
        * resolve.c (resolve_bind_c_derived_types): Handle multiple decl for
        a procedure.
        (resolve_global_procedure): Handle gsym->ns pointing to a module.
        * trans-decl.c (gfc_get_extern_function_decl): Ditto.

2013-05-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48858
        PR fortran/55465
        * gfortran.dg/binding_label_tests_10_main.f03: Update dg-error.
        * gfortran.dg/binding_label_tests_11_main.f03: Ditto.
        * gfortran.dg/binding_label_tests_13_main.f03: Ditto.
        * gfortran.dg/binding_label_tests_3.f03: Ditto.
        * gfortran.dg/binding_label_tests_4.f03: Ditto.
        * gfortran.dg/binding_label_tests_5.f03: Ditto.
        * gfortran.dg/binding_label_tests_6.f03: Ditto.
        * gfortran.dg/binding_label_tests_7.f03: Ditto.
        * gfortran.dg/binding_label_tests_8.f03: Ditto.
        * gfortran.dg/c_loc_tests_12.f03: Fix test case.
        * gfortran.dg/binding_label_tests_24.f90: New.
        * gfortran.dg/binding_label_tests_25.f90: New.

From-SVN: r199120
parent f11de7c5
Showing with 245 additions and 95 deletions
gcc/fortran/ChangeLog
2013-05-20 Tobias Burnus <burnus@net-b.de>
PR fortran/48858
PR fortran/55465
* decl.c (add_global_entry): Add sym_name.
* parse.c (add_global_procedure): Ditto.
* resolve.c (resolve_bind_c_derived_types): Handle multiple decl for
a procedure.
(resolve_global_procedure): Handle gsym->ns pointing to a module.
* trans-decl.c (gfc_get_extern_function_decl): Ditto.
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.
......
gcc/fortran/decl.c
......@@ -5375,6 +5375,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub)
else
{
s->type = type;
s->sym_name = name;
s->where = gfc_current_locus;
s->defined = 1;
s->ns = gfc_current_ns;
......@@ -5396,6 +5397,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub)
else
{
s->type = type;
s->sym_name = name;
s->binding_label = binding_label;
s->where = gfc_current_locus;
s->defined = 1;
......
gcc/fortran/parse.c
......@@ -4359,10 +4359,15 @@ add_global_procedure (bool sub)
if (s->defined
|| (s->type != GSYM_UNKNOWN
&& s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
gfc_global_used(s, NULL);
{
gfc_global_used (s, NULL);
/* Silence follow-up errors. */
gfc_new_block->binding_label = NULL;
}
else
{
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->sym_name = gfc_new_block->name;
s->where = gfc_current_locus;
s->defined = 1;
s->ns = gfc_current_ns;
......@@ -4379,10 +4384,15 @@ add_global_procedure (bool sub)
if (s->defined
|| (s->type != GSYM_UNKNOWN
&& s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
gfc_global_used(s, NULL);
{
gfc_global_used (s, NULL);
/* Silence follow-up errors. */
gfc_new_block->binding_label = NULL;
}
else
{
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->sym_name = gfc_new_block->name;
s->binding_label = gfc_new_block->binding_label;
s->where = gfc_current_locus;
s->defined = 1;
......
gcc/fortran/resolve.c
......@@ -2389,6 +2389,11 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
}
def_sym = gsym->ns->proc_name;
/* This can happen if a binding name has been specified. */
if (gsym->binding_label && gsym->sym_name != def_sym->name)
gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
if (def_sym->attr.entry_master)
{
gfc_entry_list *entry;
......@@ -10023,90 +10028,91 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym)
/* Verify that any binding labels used in a given namespace do not collide
with the names or binding labels of any global symbols. */
with the names or binding labels of any global symbols. Multiple INTERFACE
for the same procedure are permitted. */
static void
gfc_verify_binding_labels (gfc_symbol *sym)
{
int has_error = 0;
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
&& sym->attr.flavor != FL_DERIVED && sym->binding_label)
{
gfc_gsymbol *bind_c_sym;
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
if (bind_c_sym != NULL
&& strcmp (bind_c_sym->name, sym->binding_label) == 0)
{
if (sym->attr.if_source == IFSRC_DECL
&& (bind_c_sym->type != GSYM_SUBROUTINE
&& bind_c_sym->type != GSYM_FUNCTION)
&& ((sym->attr.contained == 1
&& strcmp (bind_c_sym->sym_name, sym->name) != 0)
|| (sym->attr.use_assoc == 1
&& (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
{
/* Make sure global procedures don't collide with anything. */
gfc_error ("Binding label '%s' at %L collides with the global "
"entity '%s' at %L", sym->binding_label,
&(sym->declared_at), bind_c_sym->name,
&(bind_c_sym->where));
has_error = 1;
}
else if (sym->attr.contained == 0
&& (sym->attr.if_source == IFSRC_IFBODY
&& sym->attr.flavor == FL_PROCEDURE)
&& (bind_c_sym->sym_name != NULL
&& strcmp (bind_c_sym->sym_name, sym->name) != 0))
{
/* Make sure procedures in interface bodies don't collide. */
gfc_error ("Binding label '%s' in interface body at %L collides "
"with the global entity '%s' at %L",
sym->binding_label,
&(sym->declared_at), bind_c_sym->name,
&(bind_c_sym->where));
has_error = 1;
}
else if (sym->attr.contained == 0
&& sym->attr.if_source == IFSRC_UNKNOWN)
if ((sym->attr.use_assoc && bind_c_sym->mod_name
&& strcmp (bind_c_sym->mod_name, sym->module) != 0)
|| sym->attr.use_assoc == 0)
{
gfc_error ("Binding label '%s' at %L collides with global "
"entity '%s' at %L", sym->binding_label,
&(sym->declared_at), bind_c_sym->name,
&(bind_c_sym->where));
has_error = 1;
}
if (has_error != 0)
/* Clear the binding label to prevent checking multiple times. */
sym->binding_label = NULL;
}
else if (bind_c_sym == NULL)
{
bind_c_sym = gfc_get_gsymbol (sym->binding_label);
bind_c_sym->where = sym->declared_at;
bind_c_sym->sym_name = sym->name;
gfc_gsymbol *gsym;
const char *module;
if (sym->attr.use_assoc == 1)
bind_c_sym->mod_name = sym->module;
if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
|| sym->attr.flavor == FL_DERIVED || !sym->binding_label)
return;
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
if (sym->module)
module = sym->module;
else if (sym->ns && sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
module = sym->ns->proc_name->name;
else if (sym->ns && sym->ns->parent
&& sym->ns && sym->ns->parent->proc_name
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
module = sym->ns->parent->proc_name->name;
else
if (sym->ns->proc_name != NULL)
bind_c_sym->mod_name = sym->ns->proc_name->name;
module = NULL;
if (sym->attr.contained == 0)
if (!gsym
|| (!gsym->defined
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
{
if (sym->attr.subroutine)
bind_c_sym->type = GSYM_SUBROUTINE;
else if (sym->attr.function)
bind_c_sym->type = GSYM_FUNCTION;
if (!gsym)
gsym = gfc_get_gsymbol (sym->binding_label);
gsym->where = sym->declared_at;
gsym->sym_name = sym->name;
gsym->binding_label = sym->binding_label;
gsym->binding_label = sym->binding_label;
gsym->ns = sym->ns;
gsym->mod_name = module;
if (sym->attr.function)
gsym->type = GSYM_FUNCTION;
else if (sym->attr.subroutine)
gsym->type = GSYM_SUBROUTINE;
/* Mark as variable/procedure as defined, unless its an INTERFACE. */
gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
return;
}
if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
{
gfc_error ("Variable %s with binding label %s at %L uses the same global "
"identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
/* Clear the binding label to prevent checking multiple times. */
sym->binding_label = NULL;
}
else if (sym->attr.flavor == FL_VARIABLE
&& (strcmp (module, gsym->mod_name) != 0
|| strcmp (sym->name, gsym->sym_name) != 0))
{
/* This can only happen if the variable is defined in a module - if it
isn't the same module, reject it. */
gfc_error ("Variable %s from module %s with binding label %s at %L uses "
"the same global identifier as entity at %L from module %s",
sym->name, module, sym->binding_label,
&sym->declared_at, &gsym->where, gsym->mod_name);
sym->binding_label = NULL;
}
else if ((sym->attr.function || sym->attr.subroutine)
&& ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
|| (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
&& sym != gsym->ns->proc_name
&& (strcmp (gsym->sym_name, sym->name) != 0
|| module != gsym->mod_name
|| (module && strcmp (module, gsym->mod_name) != 0)))
{
/* Print an error if the procdure is defined multiple times; we have to
exclude references to the same procedure via module association or
multiple checks for the same procedure. */
gfc_error ("Procedure %s with binding label %s at %L uses the same "
"global identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
sym->binding_label = NULL;
}
return;
}
......
gcc/fortran/trans-decl.c
......@@ -1646,6 +1646,14 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
? sym->binding_label : sym->name);
if (gsym && !gsym->defined)
gsym = NULL;
/* This can happen because of C binding. */
if (gsym && gsym->ns && gsym->ns->proc_name
&& gsym->ns->proc_name->attr.flavor == FL_MODULE)
goto module_sym;
if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
&& !sym->backend_decl
&& gsym && gsym->ns
......@@ -1702,12 +1710,19 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
if (sym->module)
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
module_sym:
if (gsym && gsym->ns
&& (gsym->type == GSYM_MODULE
|| (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
{
gfc_symbol *s;
s = NULL;
if (gsym->type == GSYM_MODULE)
gfc_find_symbol (sym->name, gsym->ns, 0, &s);
else
gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
if (s && s->backend_decl)
{
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
......
gcc/testsuite/ChangeLog
2013-05-20 Tobias Burnus <burnus@net-b.de>
PR fortran/48858
PR fortran/55465
* gfortran.dg/binding_label_tests_10_main.f03: Update dg-error.
* gfortran.dg/binding_label_tests_11_main.f03: Ditto.
* gfortran.dg/binding_label_tests_13_main.f03: Ditto.
* gfortran.dg/binding_label_tests_3.f03: Ditto.
* gfortran.dg/binding_label_tests_4.f03: Ditto.
* gfortran.dg/binding_label_tests_5.f03: Ditto.
* gfortran.dg/binding_label_tests_6.f03: Ditto.
* gfortran.dg/binding_label_tests_7.f03: Ditto.
* gfortran.dg/binding_label_tests_8.f03: Ditto.
* gfortran.dg/c_loc_tests_12.f03: Fix test case.
* gfortran.dg/binding_label_tests_24.f90: New.
* gfortran.dg/binding_label_tests_25.f90: New.
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.
......
gcc/testsuite/gfortran.dg/binding_label_tests_10_main.f03
......@@ -4,10 +4,10 @@
module binding_label_tests_10_main
use iso_c_binding
implicit none
integer(c_int), bind(c,name="c_one") :: one ! { dg-error "collides" }
integer(c_int), bind(c,name="c_one") :: one ! { dg-error "Variable one from module binding_label_tests_10 with binding label c_one at .1. uses the same global identifier as entity at .2. from module binding_label_tests_10_main" }
end module binding_label_tests_10_main
program main
use binding_label_tests_10 ! { dg-error "collides" }
use binding_label_tests_10 ! { dg-error "Variable one from module binding_label_tests_10 with binding label c_one at .1. uses the same global identifier as entity at .2. from module binding_label_tests_10_main" }
use binding_label_tests_10_main
end program main
gcc/testsuite/gfortran.dg/binding_label_tests_11_main.f03
......@@ -5,14 +5,14 @@ module binding_label_tests_11_main
use iso_c_binding, only: c_int
implicit none
contains
function one() bind(c, name="c_one") ! { dg-error "collides" }
function one() bind(c, name="c_one") ! { dg-error "Procedure one with binding label c_one at .1. uses the same global identifier as entity at .2." }
integer(c_int) one
one = 1
end function one
end module binding_label_tests_11_main
program main
use binding_label_tests_11 ! { dg-error "collides" }
use binding_label_tests_11 ! { dg-error "Procedure one with binding label c_one at .1. uses the same global identifier as entity at .2." }
use binding_label_tests_11_main
end program main
! { dg-final { cleanup-modules "binding_label_tests_11" } }
gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03
......@@ -4,12 +4,12 @@
! binding_label_tests_13.mod can not be removed until after this test is done.
module binding_label_tests_13_main
use, intrinsic :: iso_c_binding, only: c_int
integer(c_int) :: c3 ! { dg-error "collides" }
integer(c_int) :: c3 ! { dg-error "Variable c3 from module binding_label_tests_13_main with binding label c3 at .1. uses the same global identifier as entity at .2. from module binding_label_tests_13" }
bind(c) c3
contains
subroutine c_sub() BIND(c, name = "C_Sub")
use binding_label_tests_13 ! { dg-error "collides" }
use binding_label_tests_13 ! { dg-error "Variable c3 from module binding_label_tests_13_main with binding label c3 at .1. uses the same global identifier as entity at .2. from module binding_label_tests_13" }
end subroutine c_sub
end module binding_label_tests_13_main
! { dg-final { cleanup-modules "binding_label_tests_13" } }
gcc/testsuite/gfortran.dg/binding_label_tests_24.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/48858
! PR fortran/55465
!
! Was rejected before but it perfectly valid
!
module m
interface
subroutine f() bind(C, name="func")
end subroutine
end interface
contains
subroutine sub()
call f()
end subroutine
end module m
module m2
interface
subroutine g() bind(C, name="func")
end subroutine
end interface
contains
subroutine sub2()
call g()
end subroutine
end module m2
gcc/testsuite/gfortran.dg/binding_label_tests_25.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/48858
! PR fortran/55465
!
! Seems to be regarded as valid, even if it is doubtful
!
module m_odbc_if
implicit none
interface sql_set_env_attr
function sql_set_env_attr_int( input_handle,attribute,value,length ) &
result(res) bind(C,name="SQLSetEnvAttr")
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr), value :: input_handle
integer(c_int), value :: attribute
integer(c_int), value :: value ! <<<< HERE: int passed by value (int with ptr address)
integer(c_int), value :: length
integer(c_short) :: res
end function
function sql_set_env_attr_ptr( input_handle,attribute,value,length ) &
result(res) bind(C,name="SQLSetEnvAttr")
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr), value :: input_handle
integer(c_int), value :: attribute
type(c_ptr), value :: value ! <<< HERE: "void *" (pointer address)
integer(c_int), value :: length
integer(c_short) :: res
end function
end interface
end module
module graph_partitions
use,intrinsic :: iso_c_binding
interface Cfun
subroutine cfunc1 (num, array) bind(c, name="Cfun")
import :: c_int
integer(c_int),value :: num
integer(c_int) :: array(*) ! <<< HERE: int[]
end subroutine cfunc1
subroutine cfunf2 (num, array) bind(c, name="Cfun")
import :: c_int, c_ptr
integer(c_int),value :: num
type(c_ptr),value :: array ! <<< HERE: void*
end subroutine cfunf2
end interface
end module graph_partitions
program test
use graph_partitions
integer(c_int) :: a(100)
call Cfun (1, a)
call Cfun (2, C_NULL_PTR)
end program test
gcc/testsuite/gfortran.dg/binding_label_tests_3.f03
......@@ -2,14 +2,14 @@
program main
use iso_c_binding
interface
subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" }
subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! Doubtful use ...
import :: c_ptr, c_int, c_double
type(c_ptr), value :: f
integer(c_int), value :: a1, a3
real(c_double), value :: a2, a4
end subroutine p1
subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" }
subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! ... with incompatible interfaces
import :: c_ptr, c_int, c_double
type(c_ptr), value :: f
real(c_double), value :: a1, a3
......
gcc/testsuite/gfortran.dg/binding_label_tests_4.f03
......@@ -2,7 +2,7 @@
module A
use, intrinsic :: iso_c_binding
contains
subroutine pA() bind(c, name='printf') ! { dg-error "collides" }
subroutine pA() bind(c, name='printf') ! { dg-error "Procedure pb with binding label printf at .1. uses the same global identifier as entity at .2." }
print *, 'hello from pA'
end subroutine pA
end module A
......@@ -11,7 +11,7 @@ module B
use, intrinsic :: iso_c_binding
contains
subroutine pB() bind(c, name='printf') ! { dg-error "collides" }
subroutine pB() bind(c, name='printf') ! { dg-error "Procedure pb with binding label printf at .1. uses the same global identifier as entity at .2." }
print *, 'hello from pB'
end subroutine pB
end module B
......
gcc/testsuite/gfortran.dg/binding_label_tests_5.f03
......@@ -3,10 +3,10 @@ module binding_label_tests_5
use, intrinsic :: iso_c_binding
interface
subroutine sub0() bind(c, name='c_sub') ! { dg-error "collides" }
subroutine sub0() bind(c, name='c_sub') ! Odd declaration but perfectly valid
end subroutine sub0
subroutine sub1() bind(c, name='c_sub') ! { dg-error "collides" }
subroutine sub1() bind(c, name='c_sub') ! Ditto.
end subroutine sub1
end interface
end module binding_label_tests_5
gcc/testsuite/gfortran.dg/binding_label_tests_6.f03
! { dg-do compile }
module binding_label_tests_6
use, intrinsic :: iso_c_binding
integer(c_int), bind(c, name='my_int') :: my_f90_int_1 ! { dg-error "collides" }
integer(c_int), bind(c, name='my_int') :: my_f90_int_2 ! { dg-error "collides" }
integer(c_int), bind(c, name='my_int') :: my_f90_int_1 ! { dg-error "Variable my_f90_int_2 from module binding_label_tests_6 with binding label my_int at .1. uses the same global identifier as entity at .2. from module binding_label_tests_6" }
integer(c_int), bind(c, name='my_int') :: my_f90_int_2 ! { dg-error "Variable my_f90_int_2 from module binding_label_tests_6 with binding label my_int at .1. uses the same global identifier as entity at .2. from module binding_label_tests_6" }
end module binding_label_tests_6
gcc/testsuite/gfortran.dg/binding_label_tests_7.f03
! { dg-do compile }
module A
use, intrinsic :: iso_c_binding, only: c_int
integer(c_int), bind(c, name='my_c_print') :: my_int ! { dg-error "collides" }
integer(c_int), bind(c, name='my_c_print') :: my_int ! { dg-error "Procedure my_c_print with binding label my_c_print at .1. uses the same global identifier as entity at .2." }
end module A
program main
use A
interface
subroutine my_c_print() bind(c) ! { dg-error "collides" }
subroutine my_c_print() bind(c) ! { dg-error "Procedure my_c_print with binding label my_c_print at .1. uses the same global identifier as entity at .2." }
end subroutine my_c_print
end interface
......
gcc/testsuite/gfortran.dg/binding_label_tests_8.f03
! { dg-do compile }
module binding_label_tests_8
use, intrinsic :: iso_c_binding, only: c_int
integer(c_int), bind(c, name='my_f90_sub') :: my_c_int ! { dg-error "collides" }
integer(c_int), bind(c, name='my_f90_sub') :: my_c_int ! { dg-error "Variable my_c_int with binding label my_f90_sub at .1. uses the same global identifier as entity at .2." }
contains
subroutine my_f90_sub() bind(c) ! { dg-error "collides" }
subroutine my_f90_sub() bind(c) ! { dg-error "Variable my_c_int with binding label my_f90_sub at .1. uses the same global identifier as entity at .2." }
end subroutine my_f90_sub
end module binding_label_tests_8
gcc/testsuite/gfortran.dg/c_loc_tests_12.f03
......@@ -23,7 +23,7 @@ program test2
interface
subroutine sub1(argv) bind(c)
import
type(c_ptr) :: argv
type(c_ptr), intent(in) :: argv
end subroutine sub1
end interface
call sub1(c_loc(argv))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment