/* Maintain binary trees of symbols.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
*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;
goto conflict_std;
}
+ if (attr->in_namelist && (attr->allocatable || attr->pointer))
+ {
+ a1 = in_namelist;
+ a2 = attr->allocatable ? allocatable : pointer;
+ standard = GFC_STD_F2003;
+ goto conflict_std;
+ }
+
/* Check for attributes not allowed in a BLOCK DATA. */
if (gfc_current_state () == COMP_BLOCK_DATA)
{
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 (in_namelist, pointer);
- conf (in_namelist, allocatable);
-
+ 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:
return FAILURE;
}
+ if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
{
if (gfc_notify_std (GFC_STD_LEGACY,
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_array_spec (p->as);
gfc_free_expr (p->initializer);
- gfc_free (p);
+ gfc_free_formal_arglist (p->formal);
+ gfc_free_namespace (p->formal_ns);
+
+ 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;
}
-/*******A helper function for creating new expressions*************/
-
-
-gfc_expr *
-gfc_lval_expr_from_sym (gfc_symbol *sym)
-{
- gfc_expr *lval;
- lval = gfc_get_expr ();
- lval->expr_type = EXPR_VARIABLE;
- lval->where = sym->declared_at;
- lval->ts = sym->ts;
- lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
- /* It will always be a full array. */
- lval->rank = sym->as ? sym->as->rank : 0;
- if (lval->rank)
- {
- lval->ref = gfc_get_ref ();
- lval->ref->type = REF_ARRAY;
- lval->ref->u.ar.type = AR_FULL;
- lval->ref->u.ar.dimen = lval->rank;
- lval->ref->u.ar.where = sym->declared_at;
- lval->ref->u.ar.as = sym->as;
- }
-
- return lval;
-}
-
-
/************** Symbol table management subroutines ****************/
/* Basic details: Fortran 95 requires a potentially unlimited number
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);
}
return i;
}
-/* Return true if both symbols could refer to the same data object. Does
- not take account of aliasing due to equivalence statements. */
-
-int
-gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
-{
- /* Aliasing isn't possible if the symbols have different base types. */
- if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
- return 0;
-
- /* Pointers can point to other pointers, target objects and allocatable
- objects. Two allocatable objects cannot share the same storage. */
- if (lsym->attr.pointer
- && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
- return 1;
- if (lsym->attr.target && rsym->attr.pointer)
- return 1;
- if (lsym->attr.allocatable && rsym->attr.pointer)
- return 1;
-
- /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
- and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
- checked above. */
- if (lsym->attr.target && rsym->attr.target
- && ((lsym->attr.dummy && !lsym->attr.contiguous
- && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
- || (rsym->attr.dummy && !rsym->attr.contiguous
- && (!rsym->attr.dimension
- || rsym->as->type == AS_ASSUMED_SHAPE))))
- return 1;
-
- return 0;
-}
-
-
/* Undoes all the changes made to symbols in the current statement.
This subroutine is made simpler due to the fact that attributes are
never removed once added. */
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);
}
}
gfc_charlen *cl;
cl = gfc_get_charlen ();
- /* Put into namespace. */
- cl->next = ns->cl_list;
- ns->cl_list = cl;
-
/* Copy old_cl. */
if (old_cl)
{
+ /* Put into namespace, but don't allow reject_statement
+ to free it if old_cl is given. */
+ gfc_charlen **prev = &ns->cl_list;
+ cl->next = ns->old_cl_list;
+ while (*prev != ns->old_cl_list)
+ prev = &(*prev)->next;
+ *prev = cl;
+ ns->old_cl_list = cl;
cl->length = gfc_copy_expr (old_cl->length);
cl->length_from_typespec = old_cl->length_from_typespec;
cl->backend_decl = old_cl->backend_decl;
cl->passed_length = old_cl->passed_length;
cl->resolved = old_cl->resolved;
}
+ else
+ {
+ /* Put into namespace. */
+ cl->next = ns->cl_list;
+ ns->cl_list = cl;
+ }
return cl;
}
/* 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);
}
}
+/* Free entry list structs. */
+
+static void
+free_entry_list (gfc_entry_list *el)
+{
+ gfc_entry_list *next;
+
+ if (el == NULL)
+ return;
+
+ next = el->next;
+ free (el);
+ free_entry_list (next);
+}
+
+
/* Free a namespace structure and everything below it. Interface
lists associated with intrinsic operators are not freed. These are
taken care of when a specific name is freed. */
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
+ free_entry_list (ns->entries);
gfc_free_equiv (ns->equiv);
gfc_free_equiv_lists (ns->equiv_lists);
gfc_free_use_stmts (ns->use_stmts);
gfc_free_data (ns->data);
p = ns->contained;
- gfc_free (ns);
+ free (ns);
/* Recursively free any contained namespaces. */
while (p != NULL)
curr_comp = derived_sym->components;
- /* TODO: is this really an error? */
+ /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
+ empty struct. Section 15.2 in Fortran 2003 states: "The following
+ subclauses define the conditions under which a Fortran entity is
+ interoperable. If a Fortran entity is interoperable, an equivalent
+ entity may be defined by means of C and the Fortran entity is said
+ to be interoperable with the C entity. There does not have to be such
+ an interoperating C entity."
+ */
if (curr_comp == NULL)
{
- gfc_error ("Derived type '%s' at %L is empty",
- derived_sym->name, &(derived_sym->declared_at));
- return FAILURE;
+ gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
+ "and may be inaccessible by the C companion processor",
+ derived_sym->name, &(derived_sym->declared_at));
+ derived_sym->ts.is_c_interop = 1;
+ derived_sym->attr.is_bind_c = 1;
+ return SUCCESS;
}
+
/* Initialize the derived type as being C interoperable.
If we find an error in the components, this will be set false. */
derived_sym->ts.is_c_interop = 1;
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)
{
gfc_symtree *param_symtree = NULL;
gfc_formal_arglist *formal_arg = NULL;
const char *shape_param = "gfc_shape_array__";
- int i;
if (shape_param_name != NULL)
shape_param = shape_param_name;
/* Initialize the kind to default integer. However, it will be overridden
during resolution to match the kind of the SHAPE parameter given as
the actual argument (to allow for any valid integer kind). */
- param_sym->ts.kind = gfc_default_integer_kind;
+ param_sym->ts.kind = gfc_default_integer_kind;
param_sym->as = gfc_get_array_spec ();
- /* Clear out the dimension info for the array. */
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- {
- param_sym->as->lower[i] = NULL;
- param_sym->as->upper[i] = NULL;
- }
param_sym->as->rank = 1;
param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 1);
}
/* Add the interface to the symbol. */
+ gfc_free_formal_arglist (dest->formal);
dest->formal = head;
dest->attr.if_source = IFSRC_DECL;
return d;
#include "iso-c-binding.def"
#undef NAMED_INTCST
+
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+
default:
return GFC_STD_F2003;
}
{
#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
