2013-05-17 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-17 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.
@@ -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;
@@ -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;
@@ -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;
+ gfc_gsymbol *gsym;
+ const char *module;
- 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;
+ if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
+ || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
+ return;
- 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;
+ 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
+ module = NULL;
+
+ if (!gsym
+ || (!gsym->defined
+ && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
+ {
+ 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.use_assoc == 1)
- bind_c_sym->mod_name = sym->module;
- else
- if (sym->ns->proc_name != NULL)
- bind_c_sym->mod_name = sym->ns->proc_name->name;
+ 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;
- if (sym->attr.contained == 0)
- {
- if (sym->attr.subroutine)
- bind_c_sym->type = GSYM_SUBROUTINE;
- else if (sym->attr.function)
- bind_c_sym->type = GSYM_FUNCTION;
- }
- }
}
- return;
+ 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;
+ }
}
@@ -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;
- gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ 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)
@@ -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
@@ -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" } }
@@ -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" } }
@@ -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
@@ -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
@@ -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
@@ -1,6 +1,6 @@
! { 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
@@ -1,13 +1,13 @@
! { 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
@@ -1,9 +1,9 @@
! { 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
@@ -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))
@@ -0,0 +1,28 @@
+! { 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
@@ -0,0 +1,61 @@
+! { 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
Followup (and depending on) to the C binding patches for * COMMON: http://gcc.gnu.org/ml/fortran/2013-05/msg00048.html * Procedures: http://gcc.gnu.org/ml/fortran/2013-05/msg00051.html which honour Fortran 2008, where the Fortran name is no longer a global identifier if a binding name has been specified. The main reason for this patch is a build failure of Open MPI (requires !gcc$ attributes no_arg_check, i.e. it only affects GCC 4.9). Open MPI uses somethine like: interface subroutine pmpi_something() bind(C,name="MPI_something") ... and in a different module: interface subroutine mpi_something() bind(C,name="MPI_something") ... Currently, gfortran rejects it because it only permits one definition/declaration per translation unit. However, there is no reason why multiple INTERFACE blocks shouldn't be permitted. Remarks: a) Better argument checks if definition and declaration are in the same file. (see INTENT patch in a test case) b) Currently, no check is done regarding the characteristic of procedure declarations. Of course, the declaration has to be compatible with the C procedure. However, there seems to be the wish* to permit compatible input - even if the Fortran characteristic is different. For instance "int *" takes both a scalar integer ("int i; f(&i)") and arrays ("int i[5]; f(i)"). Or also popular according to the PRs: Taking a C_LOC or an integer(c_intptr_t). (* Seemingly, also J3 and/or WG5 discussed this (plenum? subgroups?) and they had the permit it. However, finding some official document is difficult.) I was wondering for a while what should be permitted and what shouldn't, but I have now decided to put that completely into the hands of the user. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias