/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "parse.h"
#include "match.h"
+#include "constructor.h"
/* Strings for all symbol attributes. We use these for dumping the
sym->ts = *ts;
sym->attr.implicit_type = 1;
- if (ts->cl)
- {
- sym->ts.cl = gfc_get_charlen ();
- *sym->ts.cl = *ts->cl;
- }
+ if (ts->type == BT_CHARACTER && ts->u.cl)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
if (sym->attr.is_bind_c == 1)
{
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
- *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
+ *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+ *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, dummy);
conf (in_common, allocatable);
+ 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, target);
conf (in_equivalence, pointer);
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 (is_bind_c, cray_pointer);
conf (is_bind_c, cray_pointee);
+ conf (is_bind_c, codimension);
conf (is_bind_c, allocatable);
conf (is_bind_c, elemental);
/* Cray pointer/pointee conflicts. */
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 (cray_pointee, dummy);
conf (data, function);
conf (data, result);
conf (data, allocatable);
- conf (data, use_assoc);
conf (value, pointer)
conf (value, allocatable)
conf (value, function)
conf (value, volatile_)
conf (value, dimension)
+ conf (value, codimension)
conf (value, external)
+ conf (codimension, result)
+
if (attr->value
&& (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
{
}
conf (is_protected, intrinsic)
- conf (is_protected, external)
conf (is_protected, in_common)
+ conf (asynchronous, intrinsic)
+ conf (asynchronous, external)
+
conf (volatile_, intrinsic)
conf (volatile_, external)
conf (procedure, allocatable)
conf (procedure, dimension)
+ conf (procedure, codimension)
conf (procedure, intrinsic)
- conf (procedure, is_protected)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
+ conf (procedure, asynchronous)
conf (procedure, entry)
a1 = gfc_code2string (flavors, attr->flavor);
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
+ conf2 (codimension);
conf2 (dimension);
conf2 (dummy);
conf2 (volatile_);
+ conf2 (asynchronous);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
if (attr->subroutine)
{
+ a1 = subroutine;
conf2 (target);
conf2 (allocatable);
+ conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (in_namelist);
+ 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);
conf2 (in_common);
conf2 (value);
conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (threadprivate);
conf2 (value);
conf2 (is_bind_c);
+ conf2 (codimension);
conf2 (result);
break;
gfc_try
-gfc_add_ext_attribute (symbol_attribute *attr, unsigned ext_attr,
+gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
locus *where ATTRIBUTE_UNUSED)
{
attr->ext_attr |= 1 << ext_attr;
gfc_try
+gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->codimension)
+ {
+ duplicate_attr ("CODIMENSION", where);
+ return FAILURE;
+ }
+
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ {
+ gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
+ "at %L", name, where);
+ return FAILURE;
+ }
+
+ attr->codimension = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
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)
+ 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);
}
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
that the local identifier made accessible by a use statement can be
- given a VOLATILE attribute. */
+ given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
if (gfc_notify_std (GFC_STD_LEGACY,
gfc_try
+gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
+{
+ /* No check_used needed as 11.2.1 of the F2003 standard allows
+ that the local identifier made accessible by a use statement can be
+ given a ASYNCHRONOUS attribute. */
+
+ if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate ASYNCHRONOUS attribute specified at %L",
+ where) == FAILURE)
+ return FAILURE;
+
+ attr->asynchronous = 1;
+ attr->asynchronous_ns = gfc_current_ns;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *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;
}
{
int is_proc_lang_bind_spec;
+ /* In line with the other attributes, we only add bits but do not remove
+ them; cf. also PR 41034. */
+ dest->ext_attr |= src->ext_attr;
+
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
if (src->dimension && gfc_add_dimension (dest, NULL, where) == 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;
if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->threadprivate
&& gfc_add_threadprivate (dest, NULL, where) == FAILURE)
goto fail;
if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
goto fail;
if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
- goto fail;
+ goto fail;
is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
if (src->is_bind_c
}
if (sym->attr.extension
- && gfc_find_component (sym->components->ts.derived, name, true, true))
+ && gfc_find_component (sym->components->ts.u.derived, name, true, true))
{
gfc_error ("Component '%s' at %C already in the parent type "
- "at %L", name, &sym->components->ts.derived->declared_at);
+ "at %L", name, &sym->components->ts.u.derived->declared_at);
return FAILURE;
}
return;
sym = st->n.sym;
- if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
- sym->ts.derived = to;
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
+ sym->ts.u.derived = to;
switch_types (st->left, from, to);
switch_types (st->right, from, to);
gfc_symtree *st;
int i;
+ if (!sym)
+ return NULL;
+
if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
for (i = 0; i < GFC_LETTERS; i++)
{
t = &sym->ns->default_type[i];
- if (t->derived == sym)
- t->derived = s;
+ if (t->u.derived == sym)
+ t->u.derived = s;
}
st = gfc_find_symtree (sym->ns->sym_root, sym->name);
{
gfc_component *p;
- if (name == NULL)
+ if (name == NULL || sym == NULL)
return NULL;
sym = gfc_use_derived (sym);
&& sym->attr.extension
&& sym->components->ts.type == BT_DERIVED)
{
- p = gfc_find_component (sym->components->ts.derived, name,
+ p = gfc_find_component (sym->components->ts.u.derived, name,
noaccess, silent);
/* Do not overwrite the error. */
if (p == NULL)
else if (sym->attr.use_assoc && !noaccess)
{
- if (p->attr.access == ACCESS_PRIVATE)
+ bool is_parent_comp = sym->attr.extension && (p == sym->components);
+ if (p->attr.access == ACCESS_PRIVATE ||
+ (p->attr.access != ACCESS_PUBLIC
+ && sym->component_access == ACCESS_PRIVATE
+ && !is_parent_comp))
{
if (!silent)
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
return NULL;
}
-
- /* If there were components given and all components are private, error
- out at this place. */
- if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
- {
- if (!silent)
- gfc_error ("All components of '%s' are PRIVATE in structure"
- " constructor at %C", sym->name);
- return NULL;
- }
}
return p;
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_get_st_label (int labelno)
{
gfc_st_label *lp;
+ gfc_namespace *ns;
+
+ 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 = gfc_current_ns->st_labels;
+ lp = ns->st_labels;
while (lp)
{
if (lp->value == labelno)
lp->defined = ST_LABEL_UNKNOWN;
lp->referenced = ST_LABEL_UNKNOWN;
- gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
+ gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
return lp;
}
}
-/*******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
ns->parent = parent;
for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
- ns->operator_access[in] = ACCESS_UNKNOWN;
+ {
+ ns->operator_access[in] = ACCESS_UNKNOWN;
+ ns->tb_op[in] = NULL;
+ }
/* Initialize default implicit types. */
for (i = 'a'; i <= 'z'; i++)
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;
}
}
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+ selector on the stack. If yes, replace it by the corresponding temporary. */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+ gfc_select_type_stack *stack = select_type_stack;
+ for (; stack; stack = stack->prev)
+ if ((*st)->n.sym == stack->selector && stack->tmp)
+ *st = stack->tmp;
+}
+
+
+/* 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. */
st = gfc_find_symtree (ns->sym_root, name);
if (st != NULL)
{
+ select_type_insert_tmp (&st);
+
*result = st;
/* Ambiguous generic interfaces are permitted, as long
as the specific interfaces are different. */
int i;
i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+
if (st != NULL)
{
save_symbol_data (st->n.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;
-
- 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. */
if (p->gfc_new)
{
/* Symbol was new. */
- if (p->attr.in_common && p->common_block->head)
+ if (p->attr.in_common && p->common_block && p->common_block->head)
{
/* If the symbol was added to any common block, it
needs to be removed to stop the resolver looking
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);
}
static void
free_uop_tree (gfc_symtree *uop_tree)
{
-
if (uop_tree == NULL)
return;
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);
}
}
}
-/* Create a new gfc_charlen structure and add it to a namespace. */
+/* Create a new gfc_charlen structure and add it to a namespace.
+ If 'old_cl' is given, the newly created charlen will be a copy of it. */
gfc_charlen*
-gfc_new_charlen (gfc_namespace *ns)
+gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
{
gfc_charlen *cl;
cl = gfc_get_charlen ();
- 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. */
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
free_tb_tree (ns->tb_sym_root);
+ free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
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)
return true;
/* Check for non-constant length character variables. */
if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && !gfc_is_constant_expr (sym->ts.cl->length))
+ && sym->ts.u.cl
+ && !gfc_is_constant_expr (sym->ts.u.cl->length))
return true;
return false;
}
/* 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;
/* BIND(C) derived types must have interoperable components. */
if (curr_comp->ts.type == BT_DERIVED
- && curr_comp->ts.derived->ts.is_iso_c != 1
- && curr_comp->ts.derived != derived_sym)
+ && curr_comp->ts.u.derived->ts.is_iso_c != 1
+ && curr_comp->ts.u.derived != derived_sym)
{
/* This should be allowed; the draft says a derived-type can not
have type parameters if it is has the BIND attribute. Type
parameters seem to be for making parameterized derived types.
There's no need to verify the type if it is c_ptr/c_funptr. */
- retval = verify_bind_c_derived_type (curr_comp->ts.derived);
+ retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
}
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 *tmp_symtree;
gfc_symbol *tmp_sym;
+ gfc_constructor *c;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
if (ptr_id == ISOCBINDING_NULL_PTR)
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.u.derived == NULL)
{
/* This can occur if the user forgot to declare c_ptr or
c_funptr and they're trying to use one of the procedures
? "_gfortran_iso_c_binding_c_ptr"
: "_gfortran_iso_c_binding_c_funptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
- tmp_sym->value->ts.derived = tmp_sym->ts.derived;
- /* Create a constructor with no expr, that way we can recognize if the user
- tries to call the structure constructor for one of the iso_c_binding
- derived types during resolution (resolve_structure_cons). */
- tmp_sym->value->value.constructor = gfc_get_constructor ();
+ tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
+ gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
+ c = gfc_constructor_first (tmp_sym->value->value.constructor);
+ c->expr = gfc_get_expr ();
+ c->expr->expr_type = EXPR_NULL;
+ c->expr->ts.is_iso_c = 1;
/* Must declare c_null_ptr and c_null_funptr as having the
PARAMETER attribute so they can be used in init expressions. */
tmp_sym->attr.flavor = FL_PARAMETER;
gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
}
- param_sym->ts.derived = c_ptr_sym;
+ param_sym->ts.u.derived = c_ptr_sym;
param_sym->module = gfc_get_string (module_name);
/* Make new formal arg. */
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_int_expr (1);
+ param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
/* The extent is unknown until we get it. The length give us
the rank the incoming pointer. */
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;
if (formal_arg->sym->ts.type == BT_CHARACTER)
- formal_arg->sym->ts.cl = gfc_new_charlen (gfc_current_ns);
+ formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
/* If this isn't the first arg, set up the next ptr. For the
last arg built, the formal_arg->next will never get set to
/* 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"
- tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
+ tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c_interop_kinds_table[s].value);
/* Initialize an integer constant expression node. */
tmp_sym->attr.flavor = FL_PARAMETER;
/* Initialize an integer constant expression node for the
length of the character. */
- tmp_sym->value = gfc_get_expr ();
- tmp_sym->value->expr_type = EXPR_CONSTANT;
- tmp_sym->value->ts.type = BT_CHARACTER;
- tmp_sym->value->ts.kind = gfc_default_character_kind;
- tmp_sym->value->where = gfc_current_locus;
+ tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, NULL, 1);
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
- tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
= (gfc_char_t) c_interop_kinds_table[s].value;
- tmp_sym->value->value.character.string[1] = '\0';
- tmp_sym->ts.cl = gfc_get_charlen ();
- tmp_sym->ts.cl->length = gfc_int_expr (1);
+ tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
tmp_sym->attr.referenced = 1;
- tmp_sym->ts.derived = tmp_sym;
+ tmp_sym->ts.u.derived = tmp_sym;
/* Add the symbol created for the derived type to the current ns. */
dt_list_ptr = &(gfc_derived_types);
C address of. */
tmp_sym->ts.type = BT_DERIVED;
if (s == ISOCBINDING_LOC)
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ if (tmp_sym->ts.u.derived == NULL)
{
/* Create the necessary derived type so we can continue
processing the file. */
(const char *)(s == ISOCBINDING_FUNLOC
? "_gfortran_iso_c_binding_c_funptr"
: "_gfortran_iso_c_binding_c_ptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR);
default:
gcc_unreachable ();
}
+ gfc_commit_symbol (tmp_sym);
}
new_symtree->n.sym->module = gfc_get_string (old_sym->module);
new_symtree->n.sym->from_intmod = old_sym->from_intmod;
new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
+ if (old_sym->attr.function)
+ new_symtree->n.sym->result = new_symtree->n.sym;
/* Build the formal arg list. */
build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
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);
gcc_assert (derived->components);
gcc_assert (derived->components->ts.type == BT_DERIVED);
- gcc_assert (derived->components->ts.derived);
+ gcc_assert (derived->components->ts.u.derived);
- return derived->components->ts.derived;
+ return derived->components->ts.u.derived;
}
-/* Find a type-bound procedure by name for a derived-type (looking recursively
- through the super-types). */
+/* Get the ultimate super-type of a given derived type. */
-gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess)
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
{
- gfc_symtree* res;
+ if (!derived->attr.extension)
+ return NULL;
- /* Set default to failure. */
- if (t)
- *t = FAILURE;
+ derived = gfc_get_derived_super_type (derived);
- /* Try to find it in the current type's namespace. */
- gcc_assert (derived->f2k_derived);
- res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
- if (res && res->n.tb)
- {
- /* We found one. */
- if (t)
- *t = SUCCESS;
+ if (derived->attr.extension)
+ return gfc_get_ultimate_derived_super_type (derived);
+ else
+ return derived;
+}
- if (!noaccess && derived->attr.use_assoc
- && res->n.tb->access == ACCESS_PRIVATE)
- {
- gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
- if (t)
- *t = FAILURE;
- }
- return res;
- }
+/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
- /* Otherwise, recurse on parent type if derived is an extension. */
- if (derived->attr.extension)
+bool
+gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
+{
+ while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
+ t2 = gfc_get_derived_super_type (t2);
+ return gfc_compare_derived_types (t1, t2);
+}
+
+
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+ If ts1 is nonpolymorphic, ts2 must be the same type.
+ If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+ bool is_class1 = (ts1->type == BT_CLASS);
+ bool is_class2 = (ts2->type == BT_CLASS);
+ bool is_derived1 = (ts1->type == BT_DERIVED);
+ bool is_derived2 = (ts2->type == BT_DERIVED);
+
+ if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+ return (ts1->type == ts2->type);
+
+ if (is_derived1 && is_derived2)
+ return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+ if (is_class1 && is_derived2)
+ return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ ts2->u.derived);
+ else if (is_class1 && is_class2)
+ return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ ts2->u.derived->components->ts.u.derived);
+ 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)
{
- gfc_symbol* super_type;
- super_type = gfc_get_derived_super_type (derived);
- gcc_assert (super_type);
- return gfc_find_typebound_proc (super_type, t, name, noaccess);
+ ns = ns->parent;
+ gcc_assert (ns);
}
- /* Nothing found. */
- return NULL;
+ return ns;
}
-/* Get a typebound-procedure symtree or create and insert it if not yet
- present. This is like a very simplified version of gfc_get_sym_tree for
- tbp-symtrees rather than regular ones. */
+/* 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). */
-gfc_symtree*
-gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
{
- gfc_symtree *result;
+ if (!sym->assoc)
+ return false;
- result = gfc_find_symtree (*root, name);
- if (!result)
- {
- result = gfc_new_symtree (root, name);
- gcc_assert (result);
- result->n.tb = NULL;
- }
+ if (!sym->assoc->variable)
+ return false;
- return result;
+ if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+ return false;
+
+ return true;
}
OSDN Git Service
