2013-05-13 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-13 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.
@@ -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 (" :: ");
@@ -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;
@@ -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);
@@ -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. */
new file mode 100644
@@ -0,0 +1,20 @@
+! { 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_" } }
new file mode 100644
@@ -0,0 +1,9 @@
+! { 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
new file mode 100644
@@ -0,0 +1,18 @@
+! { 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
+
+
new file mode 100644
@@ -0,0 +1,18 @@
+! { 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
+
+
@@ -1,9 +1,11 @@
! { 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
@@ -1,24 +1,27 @@
! { 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" } }
@@ -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" } }