diff mbox

[Fortran] PR48858 - procedures - Fix global/local identifier issues with C binding

Message ID 5192ABD2.5080106@net-b.de
State New
Headers show

Commit Message

Tobias Burnus May 14, 2013, 9:25 p.m. UTC 
This is the follow up to the patch to 
http://gcc.gnu.org/ml/fortran/2013-05/msg00048.html - While that patch 
was for COMMON, this patch is about procedures.

Fortran 2008 doesn't regard the Fortran name of procedures as global 
identifier if the procedure has a binding label; see quotes in the link 
above. Shortened quote:
F2003: "The name of a program unit ... is a global identifier"
F2008: "The name of ... [an] external procedure with no binding label 
... is a global identifier."

Changes:
* In F2008+, there is no clash between the nonbinding name if a proc has 
a binding name
* The binding name matters for calls - not the Fortran name (-> 
resolve.c, trans-decl.c)
* Sometimes, naming clashes weren't detected before.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

PS: There is still one issue related to C binding: Currently, having 
twice the same INTERFACE (same file, different scoping unit/Fortran 
name) with the same C binding is rejected - but that's perfectly valid. 
Similarly: Same binding name but slightly different interface; there are 
a few (3?) PRs about the latter issue. I am not 100% sure whether that's 
valid or not - but seemingly the J3/WG5 intended it to be valid.
diff mbox

Patch

2013-05-13  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-13  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.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 6ae51e2..cb449a2 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -5351,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;
 }
 
 
@@ -5499,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;
@@ -5524,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;
@@ -5539,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)
 	{
@@ -5590,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)
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);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e27b23b..f3607b4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2254,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);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4c0b1da..795057b 100644
--- a/gcc/fortran/trans-decl.c
+++ b/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

--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_17.f90	2013-05-14 11:04:35.960693619 +0200
@@ -0,0 +1,10 @@ 
+! { 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
+
--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_18.f90	2013-05-14 10:59:48.131447782 +0200
@@ -0,0 +1,10 @@ 
+! { 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
+
--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_19.f90	2013-05-14 10:59:50.610405492 +0200
@@ -0,0 +1,10 @@ 
+! { dg-do compile }
+!
+! PR fortran/48858
+!
+subroutine foo() bind(C,name="bar")
+end subroutine foo
+
+subroutine foo() bind(C,name="sub")
+end subroutine foo
+
--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_20.f90	2013-05-14 12:14:08.627761214 +0200
@@ -0,0 +1,11 @@ 
+! { 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
+
--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_21.f90	2013-05-14 18:06:32.301435960 +0200
@@ -0,0 +1,8 @@ 
+! { 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
+
--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_22.f90	2013-05-14 12:16:07.120723916 +0200
@@ -0,0 +1,8 @@ 
+! { 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
+
--- /dev/null	2013-05-14 08:18:25.124127481 +0200
+++ gcc/gcc/testsuite/gfortran.dg/binding_label_tests_23.f90	2013-05-14 21:30:20.279945484 +0200
@@ -0,0 +1,21 @@ 
+! { 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