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

1 files changed, 45 insertions, 15 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 8301113..ba1730a 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -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);
+  /* 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;
+	}
     }
 }
 
@@ -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);