+/* 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;
+
+ /* 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",
+ comm_block_tree->n.common->binding_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 =
+ comm_block_tree->n.common->binding_label;
+ else
+ if (strcmp (comm_name_gsym->binding_label,
+ comm_block_tree->n.common->binding_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",
+ comm_block_tree->n.common->binding_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[0] == '\0' )
+ 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. */
+
+static void
+resolve_bind_c_derived_types (gfc_symbol *derived_sym)
+{
+ if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
+ && derived_sym->attr.is_bind_c == 1)
+ verify_bind_c_derived_type (derived_sym);
+
+ return;
+}
+
+
+/* Verify that any binding labels used in a given namespace do not collide
+ with the names or binding labels of any global symbols. */
+
+static void
+gfc_verify_binding_labels (gfc_symbol *sym)
+{
+ int has_error = 0;
+
+ if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
+ && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
+ {
+ gfc_gsymbol *bind_c_sym;
+
+ bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+ if (bind_c_sym != NULL
+ && strcmp (bind_c_sym->name, sym->binding_label) == 0)
+ {
+ if (sym->attr.if_source == IFSRC_DECL
+ && (bind_c_sym->type != GSYM_SUBROUTINE
+ && bind_c_sym->type != GSYM_FUNCTION)
+ && ((sym->attr.contained == 1
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0)
+ || (sym->attr.use_assoc == 1
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
+ {
+ /* Make sure global procedures don't collide with anything. */
+ gfc_error ("Binding label '%s' at %L collides with the global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_IFBODY
+ && sym->attr.flavor == FL_PROCEDURE)
+ && (bind_c_sym->sym_name != NULL
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0))
+ {
+ /* Make sure procedures in interface bodies don't collide. */
+ gfc_error ("Binding label '%s' in interface body at %L collides "
+ "with the global entity '%s' at %L",
+ sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_UNKNOWN))
+ if ((sym->attr.use_assoc
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
+ || sym->attr.use_assoc == 0)
+ {
+ gfc_error ("Binding label '%s' at %L collides with global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+
+ if (has_error != 0)
+ /* Clear the binding label to prevent checking multiple times. */
+ sym->binding_label[0] = '\0';
+ }
+ else if (bind_c_sym == NULL)
+ {
+ bind_c_sym = gfc_get_gsymbol (sym->binding_label);
+ bind_c_sym->where = sym->declared_at;
+ bind_c_sym->sym_name = sym->name;
+
+ if (sym->attr.use_assoc == 1)
+ bind_c_sym->mod_name = sym->module;
+ else
+ if (sym->ns->proc_name != NULL)
+ bind_c_sym->mod_name = sym->ns->proc_name->name;
+
+ if (sym->attr.contained == 0)
+ {
+ if (sym->attr.subroutine)
+ bind_c_sym->type = GSYM_SUBROUTINE;
+ else if (sym->attr.function)
+ bind_c_sym->type = GSYM_FUNCTION;
+ }
+ }
+ }
+ return;
+}
+
+