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 (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
        add checks.
        (resolve_bind_c_comms): Remove.
        (resolve_types): Remove call to the latter.
        * trans-common.c (gfc_common_ns): Remove static var.
        (gfc_map_of_all_commons): Add static var.
        (build_common_decl): Correctly handle binding label.

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.
        * gfortran.dg/common_18.f90: New.
        * gfortran.dg/common_19.f90: New.
        * gfortran.dg/common_20.f90: New.
        * gfortran.dg/common_21.f90: New.

From-SVN: r199118

gcc/fortran/ChangeLog

+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
+	add checks.
+	(resolve_bind_c_comms): Remove.
+	(resolve_types): Remove call to the latter.
+	* trans-common.c (gfc_common_ns): Remove static var.
+	(gfc_map_of_all_commons): Add static var.
+	(build_common_decl): Correctly handle binding label.
+
 2013-05-16  Jason Merrill  <jason@redhat.com>
 
 	* Make-lang.in (f951$(exeext)): Use link mutex.

gcc/fortran/decl.c

@@ -4208,6 +4208,9 @@ gfc_match_bind_c_stmt (void)
 
   if (found_match == MATCH_YES)
     {
+      if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
+	return MATCH_ERROR;
+
       /* Look for the :: now, but it is not required.  */
       gfc_match (" :: ");
 

gcc/fortran/match.c

@@ -4332,7 +4332,6 @@ gfc_match_common (void)
   gfc_array_spec *as;
   gfc_equiv *e1, *e2;
   match m;
-  gfc_gsymbol *gsym;
 
   old_blank_common = gfc_current_ns->blank_common.head;
   if (old_blank_common)
@@ -4349,23 +4348,6 @@ gfc_match_common (void)
       if (m == MATCH_ERROR)
 	goto cleanup;
 
-      gsym = gfc_get_gsymbol (name);
-      if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
-	{
-	  gfc_error ("Symbol '%s' at %C is already an external symbol that "
-		     "is not COMMON", name);
-	  goto cleanup;
-	}
-
-      if (gsym->type == GSYM_UNKNOWN)
-	{
-	  gsym->type = GSYM_COMMON;
-	  gsym->where = gfc_current_locus;
-	  gsym->defined = 1;
-	}
-
-      gsym->used = 1;
-
       if (name[0] == '\0')
 	{
 	  t = &gfc_current_ns->blank_common;

gcc/fortran/resolve.c

@@ -947,6 +947,7 @@ static void
 resolve_common_blocks (gfc_symtree *common_root)
 {
   gfc_symbol *sym;
+  gfc_gsymbol * gsym;
 
   if (common_root == NULL)
     return;
@@ -958,6 +959,84 @@ resolve_common_blocks (gfc_symtree *common_root)
 
   resolve_common_vars (common_root->n.common->head, true);
 
+  /* The common name is a global name - in Fortran 2003 also if it has a
+     C binding name, since Fortran 2008 only the C binding name is a global
+     identifier.  */
+  if (!common_root->n.common->binding_label
+      || gfc_notification_std (GFC_STD_F2008))
+    {
+      gsym = gfc_find_gsymbol (gfc_gsym_root,
+			       common_root->n.common->name);
+
+      if (gsym && gfc_notification_std (GFC_STD_F2008)
+	  && gsym->type == GSYM_COMMON
+	  && ((common_root->n.common->binding_label
+	       && (!gsym->binding_label
+		   || strcmp (common_root->n.common->binding_label,
+			      gsym->binding_label) != 0))
+	      || (!common_root->n.common->binding_label
+		  && gsym->binding_label)))
+	{
+	  gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
+		     "identifier and must thus have the same binding name "
+		     "as the same-named COMMON block at %L: %s vs %s",
+		     common_root->n.common->name, &common_root->n.common->where,
+		     &gsym->where,
+		     common_root->n.common->binding_label
+		     ? common_root->n.common->binding_label : "(blank)",
+		     gsym->binding_label ? gsym->binding_label : "(blank)");
+	  return;
+	}
+
+      if (gsym && gsym->type != GSYM_COMMON
+	  && !common_root->n.common->binding_label)
+	{
+	  gfc_error ("COMMON block '%s' at %L uses the same global identifier "
+		     "as entity at %L",
+		     common_root->n.common->name, &common_root->n.common->where,
+		     &gsym->where);
+	  return;
+	}
+      if (gsym && gsym->type != GSYM_COMMON)
+	{
+	  gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
+		     "%L sharing the identifier with global non-COMMON-block "
+		     "entity at %L", common_root->n.common->name,
+		     &common_root->n.common->where, &gsym->where);
+	  return;
+	}
+      if (!gsym)
+	{
+	  gsym = gfc_get_gsymbol (common_root->n.common->name);
+	  gsym->type = GSYM_COMMON;
+	  gsym->where = common_root->n.common->where;
+	  gsym->defined = 1;
+	}
+      gsym->used = 1;
+    }
+
+  if (common_root->n.common->binding_label)
+    {
+      gsym = gfc_find_gsymbol (gfc_gsym_root,
+			       common_root->n.common->binding_label);
+      if (gsym && gsym->type != GSYM_COMMON)
+	{
+	  gfc_error ("COMMON block at %L with binding label %s uses the same "
+		     "global identifier as entity at %L",
+		     &common_root->n.common->where,
+		     common_root->n.common->binding_label, &gsym->where);
+	  return;
+	}
+      if (!gsym)
+	{
+	  gsym = gfc_get_gsymbol (common_root->n.common->binding_label);
+	  gsym->type = GSYM_COMMON;
+	  gsym->where = common_root->n.common->where;
+	  gsym->defined = 1;
+	}
+      gsym->used = 1;
+    }
+
   gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
   if (sym == NULL)
     return;
@@ -9929,103 +10008,6 @@ resolve_values (gfc_symbol *sym)
 }
 
 
-/* Verify the binding labels for common blocks that are BIND(C).  The label
-   for a BIND(C) common block must be identical in all scoping units in which
-   the common block is declared.  Further, the binding label can not collide
-   with any other global entity in the program.  */
-
-static void
-resolve_bind_c_comms (gfc_symtree *comm_block_tree)
-{
-  if (comm_block_tree->n.common->is_bind_c == 1)
-    {
-      gfc_gsymbol *binding_label_gsym;
-      gfc_gsymbol *comm_name_gsym;
-      const char * bind_label = comm_block_tree->n.common->binding_label
-	? comm_block_tree->n.common->binding_label : "";
-
-      /* See if a global symbol exists by the common block's name.  It may
-         be NULL if the common block is use-associated.  */
-      comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
-                                         comm_block_tree->n.common->name);
-      if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
-        gfc_error ("Binding label '%s' for common block '%s' at %L collides "
-                   "with the global entity '%s' at %L",
-                   bind_label,
-                   comm_block_tree->n.common->name,
-                   &(comm_block_tree->n.common->where),
-                   comm_name_gsym->name, &(comm_name_gsym->where));
-      else if (comm_name_gsym != NULL
-	       && strcmp (comm_name_gsym->name,
-			  comm_block_tree->n.common->name) == 0)
-        {
-          /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
-             as expected.  */
-          if (comm_name_gsym->binding_label == NULL)
-            /* No binding label for common block stored yet; save this one.  */
-            comm_name_gsym->binding_label = bind_label;
-          else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
-              {
-                /* Common block names match but binding labels do not.  */
-                gfc_error ("Binding label '%s' for common block '%s' at %L "
-                           "does not match the binding label '%s' for common "
-                           "block '%s' at %L",
-                           bind_label,
-                           comm_block_tree->n.common->name,
-                           &(comm_block_tree->n.common->where),
-                           comm_name_gsym->binding_label,
-                           comm_name_gsym->name,
-                           &(comm_name_gsym->where));
-                return;
-              }
-        }
-
-      /* There is no binding label (NAME="") so we have nothing further to
-         check and nothing to add as a global symbol for the label.  */
-      if (!comm_block_tree->n.common->binding_label)
-        return;
-
-      binding_label_gsym =
-        gfc_find_gsymbol (gfc_gsym_root,
-                          comm_block_tree->n.common->binding_label);
-      if (binding_label_gsym == NULL)
-        {
-          /* Need to make a global symbol for the binding label to prevent
-             it from colliding with another.  */
-          binding_label_gsym =
-            gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
-          binding_label_gsym->sym_name = comm_block_tree->n.common->name;
-          binding_label_gsym->type = GSYM_COMMON;
-        }
-      else
-        {
-          /* If comm_name_gsym is NULL, the name common block is use
-             associated and the name could be colliding.  */
-          if (binding_label_gsym->type != GSYM_COMMON)
-            gfc_error ("Binding label '%s' for common block '%s' at %L "
-                       "collides with the global entity '%s' at %L",
-                       comm_block_tree->n.common->binding_label,
-                       comm_block_tree->n.common->name,
-                       &(comm_block_tree->n.common->where),
-                       binding_label_gsym->name,
-                       &(binding_label_gsym->where));
-          else if (comm_name_gsym != NULL
-		   && (strcmp (binding_label_gsym->name,
-			       comm_name_gsym->binding_label) != 0)
-		   && (strcmp (binding_label_gsym->sym_name,
-			       comm_name_gsym->name) != 0))
-            gfc_error ("Binding label '%s' for common block '%s' at %L "
-                       "collides with global entity '%s' at %L",
-                       binding_label_gsym->name, binding_label_gsym->sym_name,
-                       &(comm_block_tree->n.common->where),
-                       comm_name_gsym->name, &(comm_name_gsym->where));
-        }
-    }
-
-  return;
-}
-
-
 /* Verify any BIND(C) derived types in the namespace so we can report errors
    for them once, rather than for each variable declared of that type.  */
 
@@ -14425,9 +14407,6 @@ resolve_types (gfc_namespace *ns)
 
   gfc_traverse_ns (ns, gfc_verify_binding_labels);
 
-  if (ns->common_root != NULL)
-    gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
-
   for (eq = ns->equiv; eq; eq = eq->next)
     resolve_equivalence (eq);
 

gcc/fortran/trans-common.c

@@ -92,6 +92,7 @@ along with GCC; see the file COPYING3.  If not see
    is examined for still-unused equivalence conditions.  We create a
    block for each merged equivalence list.  */
 
+#include <map>
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
@@ -116,7 +117,10 @@ typedef struct segment_info
 } segment_info;
 
 static segment_info * current_segment;
-static gfc_namespace *gfc_common_ns = NULL;
+
+/* Store decl of all common blocks in this translation unit; the first
+   tree is the identifier.  */
+static std::map<tree, tree> gfc_map_of_all_commons;
 
 
 /* Make a segment_info based on a symbol.  */
@@ -374,15 +378,11 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved)
 static tree
 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
 {
-  gfc_symbol *common_sym;
-  tree decl;
+  tree decl, identifier;
 
-  /* Create a namespace to store symbols for common blocks.  */
-  if (gfc_common_ns == NULL)
-    gfc_common_ns = gfc_get_namespace (NULL, 0);
-
-  gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
-  decl = common_sym->backend_decl;
+  identifier = gfc_sym_mangled_common_id (com);
+  decl = gfc_map_of_all_commons.count(identifier)
+	 ? gfc_map_of_all_commons[identifier] : NULL_TREE;
 
   /* Update the size of this common block as needed.  */
   if (decl != NULL_TREE)
@@ -419,9 +419,15 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
   /* If there is no backend_decl for the common block, build it.  */
   if (decl == NULL_TREE)
     {
-      decl = build_decl (input_location,
-			 VAR_DECL, get_identifier (com->name), union_type);
-      gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
+      if (com->is_bind_c == 1 && com->binding_label)
+	decl = build_decl (input_location, VAR_DECL, identifier, union_type);
+      else
+	{
+	  decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
+			     union_type);
+	  gfc_set_decl_assembler_name (decl, identifier);
+	}
+
       TREE_PUBLIC (decl) = 1;
       TREE_STATIC (decl) = 1;
       DECL_IGNORED_P (decl) = 1;
@@ -449,7 +455,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
 
       /* Place the back end declaration for this common block in
          GLOBAL_BINDING_LEVEL.  */
-      common_sym->backend_decl = pushdecl_top_level (decl);
+      gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
     }
 
   /* Has no initial values.  */

gcc/testsuite/ChangeLog

+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.
+	* gfortran.dg/common_18.f90: New.
+	* gfortran.dg/common_19.f90: New.
+	* gfortran.dg/common_20.f90: New.
+	* gfortran.dg/common_21.f90: New.
+
 2013-05-20  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/12288

gcc/testsuite/gfortran.dg/common_18.f90

+! { dg-do compile }
+!
+! PR fortran/48858
+!
+!
+use iso_c_binding
+contains
+subroutine one()
+  bind(C, name="com1") :: /foo/
+  integer(c_int) :: a
+  common /foo/ a
+end subroutine
+subroutine two()
+  integer(c_long) :: a
+  common /foo/ a
+end subroutine two
+end
+
+! { dg-final { scan-assembler "com1" } }
+! { dg-final { scan-assembler "foo_" } }

gcc/testsuite/gfortran.dg/common_19.f90

+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/48858
+!
+integer :: i
+common /foo/ i
+bind(C) :: /foo/ ! { dg-error "Fortran 2003: BIND.C. statement" }
+end

gcc/testsuite/gfortran.dg/common_20.f90

+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/48858
+!
+subroutine test
+  integer :: l, m
+  common /g/ l ! { dg-error "Fortran 2008: COMMON block 'g' with binding label at .1. sharing the identifier with global non-COMMON-block entity at .2." }
+  common /jj/ m ! { dg-error "Global name 'jj' at .1. is already being used as a COMMON at .2." }
+  bind(C,name="bar") :: /g/
+  bind(C,name="foo") :: /jj/
+end
+
+subroutine g ! { dg-error "Fortran 2008: COMMON block 'g' with binding label at .1. sharing the identifier with global non-COMMON-block entity at .2." }
+  call jj()  ! { dg-error "Global name 'jj' at .1. is already being used as a COMMON at .2." }
+end
+
+

gcc/testsuite/gfortran.dg/common_21.f90

+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48858
+!
+subroutine test
+  integer :: l, m
+  common /g/ l
+  common /jj/ m
+  bind(C,name="bar") :: /g/
+  bind(C,name="foo") :: /jj/
+end
+
+subroutine g
+  call jj()
+end
+
+

gcc/testsuite/gfortran.dg/test_common_binding_labels.f03

 ! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
 module x
   use, intrinsic :: iso_c_binding, only: c_double
   implicit none
 
-  common /mycom/ r, s ! { dg-error "does not match" }
+  common /mycom/ r, s ! { dg-error "In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block vs .blank.|In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block_2 vs .blank." }
   real(c_double) :: r
   real(c_double) :: s
   bind(c, name="my_common_block") :: /mycom/
@@ -13,12 +15,12 @@ module y
   use, intrinsic :: iso_c_binding, only: c_double, c_int
   implicit none
   
-  common /mycom/ r, s
+  common /mycom/ r, s ! { dg-error "In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block vs .blank." }
   real(c_double) :: r
   real(c_double) :: s
   bind(c, name="my_common_block") :: /mycom/
 
-  common /com2/ i ! { dg-error "does not match" }
+  common /com2/ i ! { dg-error " In Fortran 2003 COMMON 'com2' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: mycom2 vs .blank." }
   integer(c_int) :: i
   bind(c, name="") /com2/
 end module y
@@ -27,14 +29,14 @@ module z
   use, intrinsic :: iso_c_binding, only: c_double, c_int
   implicit none
   
-  common /mycom/ r, s ! { dg-error "does not match" }
+  common /mycom/ r, s ! { dg-error "In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block_2 vs .blank." }
   real(c_double) :: r
   real(c_double) :: s
   ! this next line is an error; if a common block is bind(c), the binding label
   ! for it must match across all scoping units that declare it.
   bind(c, name="my_common_block_2") :: /mycom/ 
 
-  common /com2/ i ! { dg-error "does not match" }
+  common /com2/ i ! { dg-error " In Fortran 2003 COMMON 'com2' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: mycom2 vs .blank." }
   integer(c_int) :: i
   bind(c, name="mycom2") /com2/
 end module z

gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03

 ! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+!
 ! This file depends on the module test_common_binding_labels_2.  That module
 ! must be compiled first and not be removed until after this test.
 module test_common_binding_labels_2_main
   use, intrinsic :: iso_c_binding, only: c_double, c_int
   implicit none
   
-  common /mycom/ r, s ! { dg-error "does not match" }
+  common /mycom/ r, s ! { dg-error "same binding name" }
   real(c_double) :: r
   real(c_double) :: s
   ! this next line is an error; if a common block is bind(c), the binding label
   ! for it must match across all scoping units that declare it.
   bind(c, name="my_common_block_2") :: /mycom/ 
 
-  common /com2/ i ! { dg-error "does not match" }
+  common /com2/ i ! { dg-error "same binding name" }
   integer(c_int) :: i
   bind(c, name="mycom2") /com2/
 end module test_common_binding_labels_2_main
 
 program main
-  use test_common_binding_labels_2 ! { dg-error "does not match" }
-  use test_common_binding_labels_2_main
+  use test_common_binding_labels_2 ! { dg-error "same binding name" }
+  use test_common_binding_labels_2_main ! { dg-error "same binding name" }
 end program main
 ! { dg-final { cleanup-modules "test_common_binding_labels_2" } }

gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03

@@ -3,11 +3,11 @@
 ! must be compiled first and not be removed until after this test.
 module test_common_binding_labels_3_main
   use, intrinsic :: iso_c_binding, only: c_int
-  integer(c_int), bind(c, name="my_common_block") :: my_int ! { dg-error "collides" }
+  integer(c_int), bind(c, name="my_common_block") :: my_int ! { dg-error "COMMON block at .1. with binding label my_common_block uses the same global identifier as entity at .2." }
 end module test_common_binding_labels_3_main
 
 program main
   use test_common_binding_labels_3_main
-  use test_common_binding_labels_3 ! { dg-error "collides" }
+  use test_common_binding_labels_3 ! { dg-error "COMMON block at .1. with binding label my_common_block uses the same global identifier as entity at .2." }
 end program main
 ! { dg-final { cleanup-modules "test_common_binding_labels_3" } }