*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
*asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
- *contiguous = "CONTIGUOUS";
+ *contiguous = "CONTIGUOUS", *generic = "GENERIC";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
conf (in_common, codimension);
conf (in_common, result);
- conf (dummy, result);
-
conf (in_equivalence, use_assoc);
conf (in_equivalence, codimension);
conf (in_equivalence, dummy);
conf (in_equivalence, allocatable);
conf (in_equivalence, threadprivate);
+ conf (dummy, result);
conf (entry, result);
+ conf (generic, result);
conf (function, subroutine);
conf2 (codimension);
conf2 (dimension);
conf2 (function);
- conf2 (threadprivate);
+ if (!attr->proc_pointer)
+ conf2 (threadprivate);
}
if (!attr->proc_pointer)
{
case PROC_ST_FUNCTION:
conf2 (dummy);
+ conf2 (target);
break;
case PROC_MODULE:
if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
{
- gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+ if (sym->attr.use_assoc)
+ gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
+ "use-associated at %L", sym->name, where, sym->module,
+ &sym->declared_at);
+ else
+ gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
where, gfc_basic_typename (type));
return FAILURE;
}
gfc_symtree *st;
int i;
+ if (!sym)
+ return NULL;
+
if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
{
gfc_component *p;
- if (name == NULL)
+ if (name == NULL || sym == NULL)
return NULL;
sym = gfc_use_derived (sym);
gfc_free_formal_arglist (p->formal);
gfc_free_namespace (p->formal_ns);
- gfc_free (p);
+ free (p);
}
}
if (label->format != NULL)
gfc_free_expr (label->format);
- gfc_free (label);
+ free (label);
}
if (label->format != NULL)
gfc_free_expr (label->format);
- gfc_free (label);
+ free (label);
}
gfc_st_label *lp;
gfc_namespace *ns;
- /* Find the namespace of the scoping unit:
- If we're in a BLOCK construct, jump to the parent namespace. */
- ns = gfc_current_ns;
- while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
- ns = ns->parent;
+ if (gfc_current_state () == COMP_DERIVED)
+ ns = gfc_current_block ()->f2k_derived;
+ else
+ {
+ /* Find the namespace of the scoping unit:
+ If we're in a BLOCK construct, jump to the parent namespace. */
+ ns = gfc_current_ns;
+ while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
+ ns = ns->parent;
+ }
/* First see if the label is already in this namespace. */
lp = ns->st_labels;
st.name = gfc_get_string (name);
gfc_delete_bbt (root, &st, compare_symtree);
- gfc_free (st0);
+ free (st0);
}
gfc_free_namespace (sym->f2k_derived);
- gfc_free (sym);
+ free (sym);
}
p->formal = old->formal;
}
- gfc_free (p->old_symbol);
+ free (p->old_symbol);
p->old_symbol = NULL;
p->tlink = NULL;
}
{
tbq = tbp->next;
/* Procedure is already marked `error' by default. */
- gfc_free (tbp);
+ free (tbp);
}
tentative_tbp_list = NULL;
}
if (sym->old_symbol->formal != sym->formal)
gfc_free_formal_arglist (sym->old_symbol->formal);
- gfc_free (sym->old_symbol);
+ free (sym->old_symbol);
sym->old_symbol = NULL;
}
{
tbq = tbp->next;
tbp->proc->error = 0;
- gfc_free (tbp);
+ free (tbp);
}
tentative_tbp_list = NULL;
}
/* TODO: Free type-bound procedure structs themselves; probably needs some
sort of ref-counting mechanism. */
- gfc_free (t);
+ free (t);
}
free_common_tree (common_tree->left);
free_common_tree (common_tree->right);
- gfc_free (common_tree);
+ free (common_tree);
}
free_uop_tree (uop_tree->right);
gfc_free_interface (uop_tree->n.uop->op);
- gfc_free (uop_tree->n.uop);
- gfc_free (uop_tree);
+ free (uop_tree->n.uop);
+ free (uop_tree);
}
free_sym_tree (sym_tree->right);
gfc_release_symbol (sym_tree->n.sym);
- gfc_free (sym_tree);
+ free (sym_tree);
}
for (dt = gfc_derived_types; dt; dt = n)
{
n = dt->next;
- gfc_free (dt);
+ free (dt);
}
gfc_derived_types = NULL;
if (s == NULL)
return;
gfc_free_equiv_infos (s->next);
- gfc_free (s);
+ free (s);
}
return;
gfc_free_equiv_lists (l->next);
gfc_free_equiv_infos (l->equiv);
- gfc_free (l);
+ free (l);
}
if (el)
{
gfc_release_symbol (el->proc_sym);
- gfc_free (el);
+ free (el);
}
}
/* Free the charlen list from cl to end (end is not freed).
Free the whole list if end is NULL. */
-void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
+void
+gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
{
gfc_charlen *cl2;
cl2 = cl->next;
gfc_free_expr (cl->length);
- gfc_free (cl);
+ free (cl);
}
}
return;
next = el->next;
- gfc_free (el);
+ free (el);
free_entry_list (next);
}
gfc_free_data (ns->data);
p = ns->contained;
- gfc_free (ns);
+ free (ns);
/* Recursively free any contained namespaces. */
while (p != NULL)
else
{
/* Grab the typespec for the given component and test the kind. */
- is_c_interop = verify_c_interop (&(curr_comp->ts));
+ is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
if (is_c_interop != SUCCESS)
{
{
#define NAMED_INTCST(a,b,c,d) case a :
-#define NAMED_REALCST(a,b,c) case a :
-#define NAMED_CMPXCST(a,b,c) case a :
+#define NAMED_REALCST(a,b,c,d) case a :
+#define NAMED_CMPXCST(a,b,c,d) case a :
#define NAMED_LOGCST(a,b,c) case a :
#define NAMED_CHARKNDCST(a,b,c) case a :
#include "iso-c-binding.def"
OSDN Git Service
