/* 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
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
- *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION";
+ *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
+ *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);
conf (cray_pointer, cray_pointee);
conf (cray_pointer, dimension);
conf (cray_pointer, codimension);
+ conf (cray_pointer, contiguous);
conf (cray_pointer, pointer);
conf (cray_pointer, target);
conf (cray_pointer, allocatable);
conf (cray_pointer, entry);
conf (cray_pointee, allocatable);
+ conf (cray_pointer, contiguous);
conf (cray_pointer, codimension);
conf (cray_pointee, intent);
conf (cray_pointee, optional);
conf (data, function);
conf (data, result);
conf (data, allocatable);
- conf (data, use_assoc);
conf (value, pointer)
conf (value, allocatable)
}
conf (is_protected, intrinsic)
- conf (is_protected, external)
conf (is_protected, in_common)
conf (asynchronous, intrinsic)
conf (procedure, dimension)
conf (procedure, codimension)
conf (procedure, intrinsic)
- conf (procedure, is_protected)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
conf2 (dummy);
conf2 (volatile_);
conf2 (asynchronous);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
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:
conf2 (function);
conf2 (subroutine);
conf2 (entry);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
gfc_try
+gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ attr->contiguous = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
gfc_try
-gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
+gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
+ locus *where)
{
if (check_used (attr, name, where))
return FAILURE;
- if (gfc_pure (NULL))
+ if (s == SAVE_EXPLICIT && gfc_pure (NULL))
{
gfc_error
("SAVE attribute at %L cannot be specified in a PURE procedure",
return FAILURE;
}
- if (attr->save == SAVE_EXPLICIT && !attr->vtab)
+ 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,
"Duplicate SAVE attribute specified at %L",
return FAILURE;
}
- attr->save = SAVE_EXPLICIT;
+ attr->save = s;
return check_conflict (attr, name, where);
}
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;
}
goto fail;
if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->optional && gfc_add_optional (dest, where) == FAILURE)
goto fail;
if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
goto fail;
- if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
+ if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
goto fail;
if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
goto fail;
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);
+}
+
+
+/* Decrease the reference counter and free memory when we reach zero. */
+
+void
+gfc_release_symbol (gfc_symbol *sym)
+{
+ if (sym == NULL)
+ return;
+
+ if (sym->formal_ns != NULL && sym->refs == 2)
+ {
+ /* As formal_ns contains a reference to sym, delete formal_ns just
+ before the deletion of sym. */
+ gfc_namespace *ns = sym->formal_ns;
+ sym->formal_ns = NULL;
+ gfc_free_namespace (ns);
+ }
+
+ sym->refs--;
+ if (sym->refs > 0)
+ return;
+
+ gcc_assert (sym->refs == 0);
+ gfc_free_symbol (sym);
}
/* Clear the ptrs we may need. */
p->common_block = NULL;
p->f2k_derived = NULL;
+ p->assoc = NULL;
return p;
}
}
+/* Look for a symtree in the current procedure -- that is, go up to
+ parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
+
+gfc_symtree*
+gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
+{
+ while (ns)
+ {
+ gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ return st;
+
+ if (!ns->construct_entities)
+ break;
+ ns = ns->parent;
+ }
+
+ return NULL;
+}
+
+
/* Search for a symtree starting in the current namespace, resorting to
any parent namespaces if requested by a nonzero parent_flag.
Returns nonzero if the name is ambiguous. */
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;
-
- 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. */
gfc_delete_symtree (&p->ns->sym_root, p->name);
- p->refs--;
- if (p->refs < 0)
- gfc_internal_error ("gfc_undo_symbols(): Negative refs");
- if (p->refs == 0)
- gfc_free_symbol (p);
+ gfc_release_symbol (p);
continue;
}
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);
}
static void
free_sym_tree (gfc_symtree *sym_tree)
{
- gfc_namespace *ns;
- gfc_symbol *sym;
-
if (sym_tree == NULL)
return;
free_sym_tree (sym_tree->left);
free_sym_tree (sym_tree->right);
- sym = sym_tree->n.sym;
-
- sym->refs--;
- if (sym->refs < 0)
- gfc_internal_error ("free_sym_tree(): Negative refs");
-
- if (sym->formal_ns != NULL && sym->refs == 1)
- {
- /* As formal_ns contains a reference to sym, delete formal_ns just
- before the deletion of sym. */
- ns = sym->formal_ns;
- sym->formal_ns = NULL;
- gfc_free_namespace (ns);
- }
- else if (sym->refs == 0)
- {
- /* Go ahead and delete the symbol. */
- gfc_free_symbol (sym);
- }
-
- gfc_free (sym_tree);
+ gfc_release_symbol (sym_tree->n.sym);
+ 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)
{
- if (el->proc_sym)
- {
- --el->proc_sym->refs;
- if (!el->proc_sym->refs)
- gfc_free_symbol (el->proc_sym);
- }
-
- gfc_free (el);
+ gfc_release_symbol (el->proc_sym);
+ 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)
/* Automatic objects are not saved. */
if (gfc_is_var_automatic (sym))
return;
- gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
+ gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
}
}
-#ifdef GFC_DEBUG
/* Make sure that no changes to symbols are pending. */
void
-gfc_symbol_state(void) {
-
- if (changed_syms != NULL)
- gfc_internal_error("Symbol changes still pending!");
+gfc_enforce_clean_symbol_state(void)
+{
+ gcc_assert (changed_syms == NULL);
}
-#endif
/************** Global symbol handling ************/
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)
{
formal_arg = gfc_get_formal_arglist ();
/* Add arg to list of formal args (the CPTR arg). */
add_formal_arg (head, tail, formal_arg, param_sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (param_sym);
}
formal_arg = gfc_get_formal_arglist ();
/* Add arg to list of formal args. */
add_formal_arg (head, tail, formal_arg, param_sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (param_sym);
}
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);
formal_arg = gfc_get_formal_arglist ();
/* Add arg to list of formal args. */
add_formal_arg (head, tail, formal_arg, param_sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (param_sym);
}
/* Add arg to list of formal args. */
add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (formal_arg->sym);
}
/* Add the interface to the symbol. */
/* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional;
+ formal_arg->sym->attr.value = curr_arg->value;
formal_arg->sym->attr.intent = curr_arg->intent;
formal_arg->sym->attr.flavor = FL_VARIABLE;
formal_arg->sym->attr.dummy = 1;
/* Add arg to list of formal args. */
add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (formal_arg->sym);
}
/* Add the interface to the symbol. */
/* Add arg to list of formal args. */
add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+
+ /* Validate changes. */
+ gfc_commit_symbol (formal_arg->sym);
}
/* 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"
default:
gcc_unreachable ();
}
+ gfc_commit_symbol (tmp_sym);
}
list and marked `error' until symbols are committed. */
gfc_typebound_proc*
-gfc_get_typebound_proc (void)
+gfc_get_typebound_proc (gfc_typebound_proc *tb0)
{
gfc_typebound_proc *result;
tentative_tbp *list_node;
result = XCNEW (gfc_typebound_proc);
+ if (tb0)
+ *result = *tb0;
result->error = 1;
list_node = XCNEW (tentative_tbp);
else
return 0;
}
+
+
+/* Find the parent-namespace of the current function. If we're inside
+ BLOCK constructs, it may not be the current one. */
+
+gfc_namespace*
+gfc_find_proc_namespace (gfc_namespace* ns)
+{
+ while (ns->construct_entities)
+ {
+ ns = ns->parent;
+ gcc_assert (ns);
+ }
+
+ return ns;
+}
+
+
+/* Check if an associate-variable should be translated as an `implicit' pointer
+ internally (if it is associated to a variable and not an array with
+ descriptor). */
+
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
+{
+ if (!sym->assoc)
+ return false;
+
+ if (!sym->assoc->variable)
+ return false;
+
+ if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+ return false;
+
+ return true;
+}
OSDN Git Service
