Hello world,
the attached patch fixes three very closely related 7/8/9 regressions.
The common root cause of these PRs was that , if a binding label
existed, gfc_get_extern_function_decl first looked for that name
in the global symbol table for that function and used its backend_decl.
If there was a module procedure with the same name as the BIND(C)
routine (perfectly legal), the wrong procedure would then be called.
The approach is straightforward: In the global symbol table, record
whether we are looking at a "normal" or a BIND(C) name, and if we
come across the wrong kind of entry in gfc_get_extern_function_decl,
just ignore it.
Regressoin-tested. OK for trunk?
Regards
Thomas
2019-03-12 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/66695
PR fortran/77746
PR fortran/79485
* gfortran.h (gfc_symbol): Add bind_c component.
(gfc_get_gsymbol): Add argument bind_c.
* decl.c (add_global_entry): Add bind_c argument to
gfc_get_symbol.
* parse.c (parse_block_data): Likewise.
(parse_module): Likewise.
(add_global_procedure): Likewise.
(add_global_program): Likewise.
* resolve.c (resolve_common_blocks): Likewise.
(resolve_global_procedure): Likewise.
(gfc_verify_binding_labels): Likewise.
* symbol.c (gfc_get_gsymbol): Add argument bind_c. Set bind_c
in gsym.
* trans-decl.c (gfc_get_module_backend_decl): Add bind_c argument
to gfc_get_symbol.
(gfc_get_extern_function_decl): If the sym has a binding label
and it cannot be found in the global symbol tabel, it is the wrong
one and vice versa.
2019-03-12 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/66695
PR fortran/77746
PR fortran/79485
* gfortran.dg/binding_label_tests_24.f90: New test.
* gfortran.dg/binding_label_tests_25.f90: New test.
* gfortran.dg/binding_label_tests_26.f90: New test.
* gfortran.dg/binding_label_tests_27.f90: New test.
Index: gfortran.h
===================================================================
--- gfortran.h (Revision 269624)
+++ gfortran.h (Arbeitskopie)
@@ -1891,6 +1891,7 @@ typedef struct gfc_gsymbol
enum gfc_symbol_type type;
int defined, used;
+ bool bind_c;
locus where;
gfc_namespace *ns;
}
@@ -3114,7 +3115,7 @@ void gfc_enforce_clean_symbol_state (void);
void gfc_free_dt_list (void);
-gfc_gsymbol *gfc_get_gsymbol (const char *);
+gfc_gsymbol *gfc_get_gsymbol (const char *, bool bind_c);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_gsymbol *gfc_find_case_gsymbol (gfc_gsymbol *, const char *);
Index: decl.c
===================================================================
--- decl.c (Revision 269624)
+++ decl.c (Arbeitskopie)
@@ -7248,7 +7248,7 @@ add_global_entry (const char *name, const char *bi
name is a global identifier. */
if (!binding_label || gfc_notification_std (GFC_STD_F2008))
{
- s = gfc_get_gsymbol (name);
+ s = gfc_get_gsymbol (name, false);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
{
@@ -7270,7 +7270,7 @@ add_global_entry (const char *name, const char *bi
&& (!gfc_notification_std (GFC_STD_F2008)
|| strcmp (name, binding_label) != 0))
{
- s = gfc_get_gsymbol (binding_label);
+ s = gfc_get_gsymbol (binding_label, true);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
{
Index: parse.c
===================================================================
--- parse.c (Revision 269624)
+++ parse.c (Arbeitskopie)
@@ -5839,7 +5839,7 @@ parse_block_data (void)
}
else
{
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
gfc_global_used (s, &gfc_new_block->declared_at);
@@ -5921,7 +5921,7 @@ parse_module (void)
gfc_gsymbol *s;
bool error;
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
gfc_global_used (s, &gfc_new_block->declared_at);
else
@@ -5985,7 +5985,7 @@ add_global_procedure (bool sub)
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);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined
|| (s->type != GSYM_UNKNOWN
@@ -6010,7 +6010,7 @@ add_global_procedure (bool sub)
&& (!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);
+ s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
if (s->defined
|| (s->type != GSYM_UNKNOWN
@@ -6042,7 +6042,7 @@ add_global_program (void)
if (gfc_new_block == NULL)
return;
- s = gfc_get_gsymbol (gfc_new_block->name);
+ s = gfc_get_gsymbol (gfc_new_block->name, false);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
gfc_global_used (s, &gfc_new_block->declared_at);
Index: resolve.c
===================================================================
--- resolve.c (Revision 269624)
+++ resolve.c (Arbeitskopie)
@@ -1050,7 +1050,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->name);
+ gsym = gfc_get_gsymbol (common_root->n.common->name, false);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
@@ -1072,7 +1072,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (!gsym)
{
- gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+ gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
gsym->type = GSYM_COMMON;
gsym->where = common_root->n.common->where;
gsym->defined = 1;
@@ -2487,7 +2487,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
+ gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
+ sym->binding_label != NULL);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
@@ -11847,7 +11848,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
{
if (!gsym)
- gsym = gfc_get_gsymbol (sym->binding_label);
+ gsym = gfc_get_gsymbol (sym->binding_label, true);
gsym->where = sym->declared_at;
gsym->sym_name = sym->name;
gsym->binding_label = sym->binding_label;
Index: symbol.c
===================================================================
--- symbol.c (Revision 269624)
+++ symbol.c (Arbeitskopie)
@@ -4330,7 +4330,7 @@ gsym_compare (void *_s1, void *_s2)
/* Get a global symbol, creating it if it doesn't exist. */
gfc_gsymbol *
-gfc_get_gsymbol (const char *name)
+gfc_get_gsymbol (const char *name, bool bind_c)
{
gfc_gsymbol *s;
@@ -4341,6 +4341,7 @@ gfc_gsymbol *
s = XCNEW (gfc_gsymbol);
s->type = GSYM_UNKNOWN;
s->name = gfc_get_string ("%s", name);
+ s->bind_c = bind_c;
gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
Index: trans-decl.c
===================================================================
--- trans-decl.c (Revision 269624)
+++ trans-decl.c (Arbeitskopie)
@@ -843,7 +843,7 @@ gfc_get_module_backend_decl (gfc_symbol *sym)
{
if (!gsym)
{
- gsym = gfc_get_gsymbol (sym->module);
+ gsym = gfc_get_gsymbol (sym->module, false);
gsym->type = GSYM_MODULE;
gsym->ns = gfc_get_namespace (NULL, 0);
}
@@ -2002,10 +2002,23 @@ gfc_get_extern_function_decl (gfc_symbol * sym, gf
return get_proc_pointer_decl (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->binding_label
- ? sym->binding_label : sym->name);
+ return the backend_decl. If we are looking at a BIND(C)
+ procedure and the symbol is not BIND(C), or vice versa, we
+ haven't found the right procedure. */
+ if (sym->binding_label)
+ {
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+ if (gsym && !gsym->bind_c)
+ gsym = NULL;
+ }
+ else
+ {
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+ if (gsym && gsym->bind_c)
+ gsym = NULL;
+ }
+
if (gsym && !gsym->defined)
gsym = NULL;
! { dg-do run }
! PR 77746 - this used to crash during execution.
! Original test case by Vladimir Fuka.
module first
private
public execute
interface execute
module procedure random_name
end interface
contains
subroutine random_name()
end subroutine
end module
module test
use first
implicit none
contains
subroutine p_execute(i) bind(C, name="random_name")
integer :: i
call execute()
end subroutine
end module
use test
call p_execute(1)
end
! { dg-do run }
! PR 79485 - used to crash because the wrong routine was called.
module fmod1
contains
subroutine foo(i)
implicit none
integer, intent(inout) :: i
i=i+1
end subroutine foo
end module fmod1
module fmod2
use iso_c_binding
use fmod1, only : foo_first => foo
contains
subroutine foo(i) bind(c)
implicit none
integer, intent(inout) :: i
i=i+2
call foo_first(i)
end subroutine foo
end module fmod2
use fmod2
call foo(i)
end
! { dg-do compile }
! PR fortran/66695 - this used to ICE.
! Original test case by Vladimir Fuka.
module mod
implicit none
contains
integer function F()
end function
end module
module mod_C
use mod
implicit none
contains
subroutine s() bind(C, name="f")
integer :: x
x = F()
end subroutine
end module
! { dg-do compile }
! Make sure this error is flagged.
subroutine foo() ! { dg-error "is already being used as a SUBROUTINE" }
end subroutine foo
subroutine bar() bind(C,name="foo") ! { dg-error "is already being used as a SUBROUTINE" }
end subroutine bar
