/* 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, 2012
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
*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)
{
a1 = gfc_code2string (flavors, attr->flavor);
a2 = save;
goto conflict;
-
+ case FL_NAMELIST:
+ gfc_error ("Namelist group name at %L cannot have the "
+ "SAVE attribute", where);
+ return FAILURE;
+ break;
case FL_PROCEDURE:
/* Conflicts between SAVE and PROCEDURE will be checked at
resolution stage, see "resolve_fl_procedure". */
case FL_VARIABLE:
- case FL_NAMELIST:
default:
break;
}
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);
+ if (!attr->is_iso_c)
+ conf2 (is_bind_c);
break;
default:
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 && !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);
}
{
/* 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;
}
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;
gfc_symtree *st;
int i;
+ if (!sym)
+ return NULL;
+
+ if (sym->attr.generic)
+ sym = gfc_find_dt_in_generic (sym);
+
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);
if (strcmp (p->name, name) == 0)
break;
+ if (p && sym->attr.use_assoc && !noaccess)
+ {
+ 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 (p == NULL
&& sym->attr.extension
&& sym->components->ts.type == BT_DERIVED)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else if (sym->attr.use_assoc && !noaccess)
- {
- if (p->attr.access == ACCESS_PRIVATE)
- {
- 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_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);
}
/* Make sure flags for symbol being C bound are clear initially. */
p->attr.is_bind_c = 0;
p->attr.is_iso_c = 0;
- /* Make sure the binding label field has a Nul char to start. */
- p->binding_label[0] = '\0';
/* Clear the ptrs we may need. */
p->common_block = NULL;
p->f2k_derived = NULL;
+ p->assoc = NULL;
return p;
}
{
gfc_select_type_stack *stack = select_type_stack;
for (; stack; stack = stack->prev)
- if ((*st)->n.sym == stack->selector)
+ 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. */
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);
+ /* The derived type is saved in the symtree with the first
+ letter capitalized; the all lower-case version to the
+ derived type contains its associated generic function. */
+ if (p->attr.flavor == FL_DERIVED)
+ gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) p->name[0]),
+ &p->name[1]));
+ else
+ 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)
}
-/* Clear mark bits from symbol nodes associated with a symtree node. */
+/* Count how many nodes a symtree has. */
-static void
-clear_sym_mark (gfc_symtree *st)
+static unsigned
+count_st_nodes (const gfc_symtree *st)
{
+ unsigned nodes;
+ if (!st)
+ return 0;
- st->n.sym->mark = 0;
+ nodes = count_st_nodes (st->left);
+ nodes++;
+ nodes += count_st_nodes (st->right);
+
+ return nodes;
}
-/* Recursively traverse the symtree nodes. */
+/* Convert symtree tree into symtree vector. */
-void
-gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
+static unsigned
+fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
{
if (!st)
- return;
+ return node_cntr;
+
+ node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
+ st_vec[node_cntr++] = st;
+ node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
- gfc_traverse_symtree (st->left, func);
- (*func) (st);
- gfc_traverse_symtree (st->right, func);
+ return node_cntr;
}
-/* Recursive namespace traversal function. */
+/* Traverse namespace. As the functions might modify the symtree, we store the
+ symtree as a vector and operate on this vector. Note: We assume that
+ sym_func or st_func never deletes nodes from the symtree - only adding is
+ allowed. Additionally, newly added nodes are not traversed. */
static void
-traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
+do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
+ void (*sym_func) (gfc_symbol *))
{
+ gfc_symtree **st_vec;
+ unsigned nodes, i, node_cntr;
- if (st == NULL)
- return;
+ gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
+ nodes = count_st_nodes (st);
+ st_vec = XALLOCAVEC (gfc_symtree *, nodes);
+ node_cntr = 0;
+ fill_st_vector (st, st_vec, node_cntr);
- traverse_ns (st->left, func);
+ if (sym_func)
+ {
+ /* Clear marks. */
+ for (i = 0; i < nodes; i++)
+ st_vec[i]->n.sym->mark = 0;
+ for (i = 0; i < nodes; i++)
+ if (!st_vec[i]->n.sym->mark)
+ {
+ (*sym_func) (st_vec[i]->n.sym);
+ st_vec[i]->n.sym->mark = 1;
+ }
+ }
+ else
+ for (i = 0; i < nodes; i++)
+ (*st_func) (st_vec[i]);
+}
- if (st->n.sym->mark == 0)
- (*func) (st->n.sym);
- st->n.sym->mark = 1;
- traverse_ns (st->right, func);
+/* Recursively traverse the symtree nodes. */
+
+void
+gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
+{
+ do_traverse_symtree (st, st_func, NULL);
}
care that each gfc_symbol node is called exactly once. */
void
-gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
+gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
{
-
- gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
-
- traverse_ns (ns->sym_root, func);
+ do_traverse_symtree (ns->sym_root, NULL, sym_func);
}
/* 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)
{
{
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym;
+ gfc_constructor *c;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
"create symbol for %s", ptr_name);
}
- /* Set up the symbol's important fields. Save attr required so we can
- initialize the ptr to NULL. */
- tmp_sym->attr.save = SAVE_EXPLICIT;
tmp_sym->ts.is_c_interop = 1;
tmp_sym->attr.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->ts.type = BT_DERIVED;
+ tmp_sym->attr.flavor = FL_PARAMETER;
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
that has arg(s) of the missing type. In this case, a
regular version of the thing should have been put in the
current ns. */
+
generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
(const char *) (ptr_id == ISOCBINDING_NULL_PTR
- ? "_gfortran_iso_c_binding_c_ptr"
- : "_gfortran_iso_c_binding_c_funptr"));
-
+ ? "c_ptr"
+ : "c_funptr"));
tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
- ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
+ get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
/* Module name is some mangled version of iso_c_binding. */
tmp_sym->attr.use_assoc = 1;
tmp_sym->attr.is_bind_c = 1;
- /* Set the binding_label. */
- sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
+ /* Since we never generate a call to this symbol, don't set the
+ binding_label. */
/* Set the c_address field of c_null_ptr and c_null_funptr to
the value of NULL. */
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.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 ();
- /* 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_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;
return SUCCESS;
}
const char *c_ptr_type = NULL;
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
- c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
+ c_ptr_type = "c_funptr";
else
- c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
+ c_ptr_type = "c_ptr";
if(c_ptr_name == NULL)
c_ptr_in = "gfc_cptr__";
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;
/* 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;
}
: c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree = NULL;
gfc_symbol *tmp_sym = NULL;
- gfc_dt_list **dt_list_ptr = NULL;
- gfc_component *tmp_comp = NULL;
- char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
return;
+
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
- /* Already exists in this scope so don't re-add it.
- TODO: we should probably check that it's really the same symbol. */
- if (tmp_symtree != NULL)
- return;
+ /* Already exists in this scope so don't re-add it. */
+ if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
+ && (!tmp_sym->attr.generic
+ || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
+ && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
+ {
+ if (tmp_sym->attr.flavor == FL_DERIVED
+ && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
+ {
+ gfc_dt_list *dt_list;
+ dt_list = gfc_get_dt_list ();
+ dt_list->derived = tmp_sym;
+ dt_list->next = gfc_derived_types;
+ gfc_derived_types = dt_list;
+ }
+
+ return;
+ }
/* Create the sym tree in the current ns. */
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
{
#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.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- tmp_sym->ts.u.cl->length = gfc_int_expr (1);
+ 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. */
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
-
- /* Initialize an integer constant expression node. */
- tmp_sym->attr.flavor = FL_DERIVED;
- tmp_sym->ts.is_c_interop = 1;
- tmp_sym->attr.is_c_interop = 1;
- tmp_sym->attr.is_iso_c = 1;
- tmp_sym->ts.is_iso_c = 1;
- tmp_sym->ts.type = BT_DERIVED;
-
- /* A derived type must have the bind attribute to be
- interoperable (J3/04-007, Section 15.2.3), even though
- the binding label is not used. */
- tmp_sym->attr.is_bind_c = 1;
-
- tmp_sym->attr.referenced = 1;
-
- 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);
- while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
- dt_list_ptr = &((*dt_list_ptr)->next);
-
- /* There is already at least one derived type in the list, so append
- the one we're currently building for c_ptr or c_funptr. */
- if (*dt_list_ptr != NULL)
- dt_list_ptr = &((*dt_list_ptr)->next);
- (*dt_list_ptr) = gfc_get_dt_list ();
- (*dt_list_ptr)->derived = tmp_sym;
- (*dt_list_ptr)->next = NULL;
-
- /* Set up the component of the derived type, which will be
- an integer with kind equal to c_ptr_size. Mangle the name of
- the field for the c_address to prevent the curious user from
- trying to access it from Fortran. */
- sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
- gfc_add_component (tmp_sym, comp_name, &tmp_comp);
- if (tmp_comp == NULL)
+ {
+ gfc_interface *intr, *head;
+ gfc_symbol *dt_sym;
+ const char *hidden_name;
+ gfc_dt_list **dt_list_ptr = NULL;
+ gfc_component *tmp_comp = NULL;
+ char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
+
+ hidden_name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
+ &tmp_sym->name[1]);
+
+ /* Generate real derived type. */
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ hidden_name);
+
+ if (tmp_symtree != NULL)
+ gcc_unreachable ();
+ gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
+ if (tmp_symtree)
+ dt_sym = tmp_symtree->n.sym;
+ else
+ gcc_unreachable ();
+
+ /* Generate an artificial generic function. */
+ dt_sym->name = gfc_get_string (tmp_sym->name);
+ head = tmp_sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ tmp_sym->generic = intr;
+
+ if (!tmp_sym->attr.generic
+ && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
+ == FAILURE)
+ return;
+
+ if (!tmp_sym->attr.function
+ && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
+ == FAILURE)
+ return;
+
+ /* Say what module this symbol belongs to. */
+ dt_sym->module = gfc_get_string (mod_name);
+ dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ dt_sym->intmod_sym_id = s;
+
+ /* Initialize an integer constant expression node. */
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->ts.is_c_interop = 1;
+ dt_sym->attr.is_c_interop = 1;
+ dt_sym->attr.is_iso_c = 1;
+ dt_sym->ts.is_iso_c = 1;
+ dt_sym->ts.type = BT_DERIVED;
+
+ /* A derived type must have the bind attribute to be
+ interoperable (J3/04-007, Section 15.2.3), even though
+ the binding label is not used. */
+ dt_sym->attr.is_bind_c = 1;
+
+ dt_sym->attr.referenced = 1;
+ dt_sym->ts.u.derived = dt_sym;
+
+ /* Add the symbol created for the derived type to the current ns. */
+ dt_list_ptr = &(gfc_derived_types);
+ while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+
+ /* There is already at least one derived type in the list, so append
+ the one we're currently building for c_ptr or c_funptr. */
+ if (*dt_list_ptr != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+ (*dt_list_ptr) = gfc_get_dt_list ();
+ (*dt_list_ptr)->derived = dt_sym;
+ (*dt_list_ptr)->next = NULL;
+
+ /* Set up the component of the derived type, which will be
+ an integer with kind equal to c_ptr_size. Mangle the name of
+ the field for the c_address to prevent the curious user from
+ trying to access it from Fortran. */
+ sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
+ gfc_add_component (dt_sym, comp_name, &tmp_comp);
+ if (tmp_comp == NULL)
gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
"create component for c_address");
- tmp_comp->ts.type = BT_INTEGER;
+ tmp_comp->ts.type = BT_INTEGER;
- /* Set this because the module will need to read/write this field. */
- tmp_comp->ts.f90_type = BT_INTEGER;
+ /* Set this because the module will need to read/write this field. */
+ tmp_comp->ts.f90_type = BT_INTEGER;
- /* The kinds for c_ptr and c_funptr are the same. */
- index = get_c_kind ("c_ptr", c_interop_kinds_table);
- tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+ /* The kinds for c_ptr and c_funptr are the same. */
+ index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ tmp_comp->ts.kind = c_interop_kinds_table[index].value;
- tmp_comp->attr.pointer = 0;
- tmp_comp->attr.dimension = 0;
+ tmp_comp->attr.pointer = 0;
+ tmp_comp->attr.dimension = 0;
- /* Mark the component as C interoperable. */
- tmp_comp->ts.is_c_interop = 1;
+ /* Mark the component as C interoperable. */
+ tmp_comp->ts.is_c_interop = 1;
+
+ /* Make it use associated (iso_c_binding module). */
+ dt_sym->attr.use_assoc = 1;
+ }
- /* Make it use associated (iso_c_binding module). */
- tmp_sym->attr.use_assoc = 1;
break;
case ISOCBINDING_NULL_PTR:
/* Use the procedure's name as it is in the iso_c_binding module for
setting the binding label in case the user renamed the symbol. */
- sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
- c_interop_kinds_table[s].name);
+ tmp_sym->binding_label =
+ gfc_get_string ("%s_%s", mod_name,
+ c_interop_kinds_table[s].name);
tmp_sym->attr.is_iso_c = 1;
if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
tmp_sym->attr.subroutine = 1;
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.u.derived == NULL)
- {
+ if (tmp_sym->ts.u.derived == NULL)
+ {
/* Create the necessary derived type so we can continue
processing the file. */
- generate_isocbinding_symbol
+ generate_isocbinding_symbol
(mod_name, s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
- (const char *)(s == ISOCBINDING_FUNLOC
- ? "_gfortran_iso_c_binding_c_funptr"
- : "_gfortran_iso_c_binding_c_ptr"));
+ ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
+ (const char *)(s == ISOCBINDING_FUNLOC
+ ? "c_funptr" : "c_ptr"));
tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR
- : ISOCBINDING_PTR);
- }
+ get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR
+ : ISOCBINDING_PTR);
+ }
/* The function result is itself (no result clause). */
tmp_sym->result = tmp_sym;
default:
gcc_unreachable ();
}
+ gfc_commit_symbol (tmp_sym);
}
gfc_symbol *
get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
- char *new_binding_label, int add_optional_arg)
+ const char *new_binding_label, int add_optional_arg)
{
gfc_symtree *new_symtree = NULL;
"symtree for '%s'", new_name);
/* Now fill in the fields of the resolved symbol with the old sym. */
- strcpy (new_symtree->n.sym->binding_label, new_binding_label);
+ new_symtree->n.sym->binding_label = new_binding_label;
new_symtree->n.sym->attr = old_sym->attr;
new_symtree->n.sym->ts = old_sym->ts;
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);
gfc_symbol*
gfc_get_derived_super_type (gfc_symbol* derived)
{
+ if (derived && derived->attr.generic)
+ derived = gfc_find_dt_in_generic (derived);
+
if (!derived->attr.extension)
return NULL;
gcc_assert (derived->components->ts.type == BT_DERIVED);
gcc_assert (derived->components->ts.u.derived);
+ if (derived->components->ts.u.derived->attr.generic)
+ return gfc_find_dt_in_generic (derived->components->ts.u.derived);
+
return derived->components->ts.u.derived;
}
bool
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
{
- gfc_component *cmp1, *cmp2;
-
bool is_class1 = (ts1->type == BT_CLASS);
bool is_class2 = (ts2->type == BT_CLASS);
bool is_derived1 = (ts1->type == BT_DERIVED);
if (is_derived1 && is_derived2)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
- cmp1 = cmp2 = NULL;
-
- if (is_class1)
- {
- cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
- if (cmp1 == NULL)
- return 0;
- }
-
- if (is_class2)
- {
- cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
- if (cmp2 == NULL)
- return 0;
- }
-
if (is_class1 && is_derived2)
- return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
-
+ 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 (cmp1->ts.u.derived, cmp2->ts.u.derived);
-
+ return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ ts2->u.derived->components->ts.u.derived);
else
return 0;
}
-/* Build a polymorphic CLASS entity, using the symbol that comes from
- build_sym. A CLASS entity is represented by an encapsulating type,
- which contains the declared type as '$data' component, plus a pointer
- component '$vptr' which determines the dynamic type. */
-
-gfc_try
-gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as)
-{
- char name[GFC_MAX_SYMBOL_LEN + 5];
- gfc_symbol *fclass;
- gfc_symbol *vtab;
- gfc_component *c;
-
- /* Determine the name of the encapsulating type. */
- if ((*as) && (*as)->rank && attr->allocatable)
- sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
- else if ((*as) && (*as)->rank)
- sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
- else if (attr->allocatable)
- sprintf (name, ".class.%s.a", ts->u.derived->name);
- else
- sprintf (name, ".class.%s", ts->u.derived->name);
-
- gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
- if (fclass == NULL)
- {
- gfc_symtree *st;
- /* If not there, create a new symbol. */
- fclass = gfc_new_symbol (name, ts->u.derived->ns);
- st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
- st->n.sym = fclass;
- gfc_set_sym_referenced (fclass);
- fclass->refs++;
- fclass->ts.type = BT_UNKNOWN;
- fclass->attr.abstract = ts->u.derived->attr.abstract;
- if (ts->u.derived->f2k_derived)
- fclass->f2k_derived = gfc_get_namespace (NULL, 0);
- if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
- NULL, &gfc_current_locus) == FAILURE)
- return FAILURE;
-
- /* Add component '$data'. */
- if (gfc_add_component (fclass, "$data", &c) == FAILURE)
- return FAILURE;
- c->ts = *ts;
- c->ts.type = BT_DERIVED;
- c->attr.access = ACCESS_PRIVATE;
- c->ts.u.derived = ts->u.derived;
- c->attr.pointer = attr->pointer || attr->dummy;
- c->attr.allocatable = attr->allocatable;
- c->attr.dimension = attr->dimension;
- c->attr.abstract = ts->u.derived->attr.abstract;
- c->as = (*as);
- c->initializer = gfc_get_expr ();
- c->initializer->expr_type = EXPR_NULL;
-
- /* Add component '$vptr'. */
- if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
- return FAILURE;
- c->ts.type = BT_DERIVED;
- vtab = gfc_find_derived_vtab (ts->u.derived);
- gcc_assert (vtab);
- c->ts.u.derived = vtab->ts.u.derived;
- c->attr.pointer = 1;
- c->initializer = gfc_get_expr ();
- c->initializer->expr_type = EXPR_NULL;
- }
-
- /* Since the extension field is 8 bit wide, we can only have
- up to 255 extension levels. */
- if (ts->u.derived->attr.extension == 255)
- {
- gfc_error ("Maximum extension level reached with type '%s' at %L",
- ts->u.derived->name, &ts->u.derived->declared_at);
- return FAILURE;
- }
-
- fclass->attr.extension = ts->u.derived->attr.extension + 1;
- fclass->attr.is_class = 1;
- ts->u.derived = fclass;
- attr->allocatable = attr->pointer = attr->dimension = 0;
- (*as) = NULL; /* XXX */
- return SUCCESS;
-}
-
-
-/* Find the symbol for a derived type's vtab. */
-
-gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived)
-{
- gfc_namespace *ns;
- gfc_symbol *vtab = NULL, *vtype = NULL;
- char name[2 * GFC_MAX_SYMBOL_LEN + 8];
-
- ns = gfc_current_ns;
-
- for (; ns; ns = ns->parent)
- if (!ns->parent)
- break;
-
- if (ns)
- {
- sprintf (name, "vtab$%s", derived->name);
- gfc_find_symbol (name, ns, 0, &vtab);
-
- if (vtab == NULL)
- {
- gfc_get_symbol (name, ns, &vtab);
- vtab->ts.type = BT_DERIVED;
- vtab->attr.flavor = FL_VARIABLE;
- vtab->attr.target = 1;
- vtab->attr.save = SAVE_EXPLICIT;
- vtab->attr.vtab = 1;
- vtab->refs++;
- gfc_set_sym_referenced (vtab);
- sprintf (name, "vtype$%s", derived->name);
-
- gfc_find_symbol (name, ns, 0, &vtype);
- if (vtype == NULL)
- {
- gfc_component *c;
- gfc_symbol *parent = NULL, *parent_vtab = NULL;
-
- gfc_get_symbol (name, ns, &vtype);
- if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
- NULL, &gfc_current_locus) == FAILURE)
- return NULL;
- vtype->refs++;
- gfc_set_sym_referenced (vtype);
-
- /* Add component '$hash'. */
- if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
- return NULL;
- c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
- c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_int_expr (derived->hash_value);
-
- /* Add component '$size'. */
- if (gfc_add_component (vtype, "$size", &c) == FAILURE)
- return NULL;
- c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
- c->attr.access = ACCESS_PRIVATE;
- /* Remember the derived type in ts.u.derived,
- so that the correct initializer can be set later on
- (in gfc_conv_structure). */
- c->ts.u.derived = derived;
- c->initializer = gfc_int_expr (0);
-
- /* Add component $extends. */
- if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
- return NULL;
- c->attr.pointer = 1;
- c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_get_expr ();
- parent = gfc_get_derived_super_type (derived);
- if (parent)
- {
- parent_vtab = gfc_find_derived_vtab (parent);
- c->ts.type = BT_DERIVED;
- c->ts.u.derived = parent_vtab->ts.u.derived;
- c->initializer->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
- &c->initializer->symtree);
- }
- else
- {
- c->ts.type = BT_DERIVED;
- c->ts.u.derived = vtype;
- c->initializer->expr_type = EXPR_NULL;
- }
- }
- vtab->ts.u.derived = vtype;
-
- vtab->value = gfc_default_initializer (&vtab->ts);
- }
- }
-
- return vtab;
-}
-
-
-/* General worker function to find either a type-bound procedure or a
- type-bound user operator. */
+/* Find the parent-namespace of the current function. If we're inside
+ BLOCK constructs, it may not be the current one. */
-static gfc_symtree*
-find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess, bool uop,
- locus* where)
+gfc_namespace*
+gfc_find_proc_namespace (gfc_namespace* ns)
{
- gfc_symtree* res;
- gfc_symtree* root;
-
- /* Set correct symbol-root. */
- gcc_assert (derived->f2k_derived);
- root = (uop ? derived->f2k_derived->tb_uop_root
- : derived->f2k_derived->tb_sym_root);
-
- /* Set default to failure. */
- if (t)
- *t = FAILURE;
-
- /* Try to find it in the current type's namespace. */
- res = gfc_find_symtree (root, name);
- if (res && res->n.tb && !res->n.tb->error)
+ while (ns->construct_entities)
{
- /* We found one. */
- if (t)
- *t = SUCCESS;
-
- if (!noaccess && derived->attr.use_assoc
- && res->n.tb->access == ACCESS_PRIVATE)
- {
- if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
- name, derived->name, where);
- if (t)
- *t = FAILURE;
- }
-
- return res;
- }
-
- /* Otherwise, recurse on parent type if derived is an extension. */
- if (derived->attr.extension)
- {
- gfc_symbol* super_type;
- super_type = gfc_get_derived_super_type (derived);
- gcc_assert (super_type);
-
- return find_typebound_proc_uop (super_type, t, name,
- noaccess, uop, where);
+ ns = ns->parent;
+ gcc_assert (ns);
}
- /* Nothing found. */
- return NULL;
-}
-
-
-/* Find a type-bound procedure or user operator by name for a derived-type
- (looking recursively through the super-types). */
-
-gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess, locus* where)
-{
- return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
-}
-
-gfc_symtree*
-gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess, locus* where)
-{
- return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
+ return ns;
}
-/* Find a type-bound intrinsic operator looking recursively through the
- super-type hierarchy. */
+/* 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_typebound_proc*
-gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
- gfc_intrinsic_op op, bool noaccess,
- locus* where)
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
{
- gfc_typebound_proc* res;
-
- /* Set default to failure. */
- if (t)
- *t = FAILURE;
-
- /* Try to find it in the current type's namespace. */
- if (derived->f2k_derived)
- res = derived->f2k_derived->tb_op[op];
- else
- res = NULL;
-
- /* Check access. */
- if (res && !res->error)
- {
- /* We found one. */
- if (t)
- *t = SUCCESS;
-
- if (!noaccess && derived->attr.use_assoc
- && res->access == ACCESS_PRIVATE)
- {
- if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
- gfc_op2string (op), derived->name, where);
- if (t)
- *t = FAILURE;
- }
-
- return res;
- }
+ if (!sym->assoc)
+ return false;
- /* Otherwise, recurse on parent type if derived is an extension. */
- if (derived->attr.extension)
- {
- gfc_symbol* super_type;
- super_type = gfc_get_derived_super_type (derived);
- gcc_assert (super_type);
+ if (!sym->assoc->variable)
+ return false;
- return gfc_find_typebound_intrinsic_op (super_type, t, op,
- noaccess, where);
- }
+ if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+ return false;
- /* Nothing found. */
- return NULL;
+ return true;
}
-/* 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. */
-
-gfc_symtree*
-gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+gfc_symbol *
+gfc_find_dt_in_generic (gfc_symbol *sym)
{
- gfc_symtree *result;
+ gfc_interface *intr = NULL;
- result = gfc_find_symtree (*root, name);
- if (!result)
- {
- result = gfc_new_symtree (root, name);
- gcc_assert (result);
- result->n.tb = NULL;
- }
+ if (!sym || sym->attr.flavor == FL_DERIVED)
+ return sym;
- return result;
+ if (sym->attr.generic)
+ for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ break;
+ return intr ? intr->sym : NULL;
}
OSDN Git Service
