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

gcc/fortran/ChangeLog

 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
 	* decl.c (gfc_match_bind_c_stmt): Add gfc_notify_std.
 	* match.c (gfc_match_common): Don't add commons to gsym.
 	* resolve.c (resolve_common_blocks): Add to gsym and

gcc/fortran/decl.c

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

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

gcc/fortran/resolve.c

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

gcc/fortran/trans-decl.c

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

gcc/testsuite/ChangeLog

 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
 	* gfortran.dg/test_common_binding_labels.f03: Update dg-error.
 	* gfortran.dg/test_common_binding_labels_2_main.f03: Ditto.
 	* gfortran.dg/test_common_binding_labels_3_main.f03: Ditto.

gcc/testsuite/gfortran.dg/binding_label_tests_17.f90

+! { 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
+

gcc/testsuite/gfortran.dg/binding_label_tests_18.f90

+! { 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
+

gcc/testsuite/gfortran.dg/binding_label_tests_19.f90

+! { dg-do compile }
+!
+! PR fortran/48858
+!
+subroutine foo() bind(C,name="bar")
+end subroutine foo
+
+subroutine foo() bind(C,name="sub")
+end subroutine foo
+

gcc/testsuite/gfortran.dg/binding_label_tests_20.f90

+! { 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
+

gcc/testsuite/gfortran.dg/binding_label_tests_21.f90

+! { 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
+

gcc/testsuite/gfortran.dg/binding_label_tests_22.f90

+! { 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
+

gcc/testsuite/gfortran.dg/binding_label_tests_23.f90

+! { 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