/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
- Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
{
minit ("UNKNOWN", IFSRC_UNKNOWN),
minit ("DECL", IFSRC_DECL),
- minit ("BODY", IFSRC_IFBODY),
- minit ("USAGE", IFSRC_USAGE)
+ minit ("BODY", IFSRC_IFBODY)
};
const mstring save_status[] =
gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
gfc_gsymbol *gfc_gsym_root = NULL;
gfc_dt_list *gfc_derived_types;
+/* List of tentative typebound-procedures. */
+
+typedef struct tentative_tbp
+{
+ gfc_typebound_proc *proc;
+ struct tentative_tbp *next;
+}
+tentative_tbp;
+
+static tentative_tbp *tentative_tbp_list = NULL;
+
+
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
/* The following static variable indicates whether a particular element has
{
if (new_flag[i])
{
-
if (gfc_current_ns->set_flag[i])
{
gfc_error ("Letter %c already has an IMPLICIT type at %C",
i + 'A');
return FAILURE;
}
+
gfc_current_ns->default_type[i] = *ts;
+ gfc_current_ns->implicit_loc[i] = gfc_current_locus;
gfc_current_ns->set_flag[i] = 1;
}
}
/* Given a symbol, return a pointer to the typespec for its default type. */
gfc_typespec *
-gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
+gfc_get_default_type (const char *name, gfc_namespace *ns)
{
char letter;
- letter = sym->name[0];
+ letter = name[0];
if (gfc_option.flag_allow_leading_underscore && letter == '_')
gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
"implicitly typed variables");
if (letter < 'a' || letter > 'z')
- gfc_internal_error ("gfc_get_default_type(): Bad symbol");
+ gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
if (ns == NULL)
ns = gfc_current_ns;
if (sym->ts.type != BT_UNKNOWN)
gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
- ts = gfc_get_default_type (sym, ns);
+ ts = gfc_get_default_type (sym->name, ns);
if (ts->type == BT_UNKNOWN)
{
sym->ts = *ts;
sym->attr.implicit_type = 1;
+ 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)
{
/* BIND(C) variables should not be implicitly declared. */
if (!proc->attr.contained || proc->result->attr.implicit_type)
return;
- if (proc->result->ts.type == BT_UNKNOWN)
+ if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
{
if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
== SUCCESS)
proc->attr.allocatable = proc->result->attr.allocatable;
}
}
- else
+ else if (!proc->result->attr.proc_pointer)
{
gfc_error ("Function result '%s' at %L has no IMPLICIT type",
proc->result->name, &proc->result->declared_at);
*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";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
conf (entry, intrinsic);
if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
- {
- conf (external, subroutine);
- conf (external, function);
- }
+ conf (external, subroutine);
+
+ if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: Procedure pointer at %C") == FAILURE)
+ return FAILURE;
conf (allocatable, pointer);
conf_std (allocatable, dummy, GFC_STD_F2003);
conf (is_protected, external)
conf (is_protected, in_common)
+ conf (asynchronous, intrinsic)
+ conf (asynchronous, external)
+
conf (volatile_, intrinsic)
conf (volatile_, external)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
+ conf (procedure, asynchronous)
conf (procedure, entry)
a1 = gfc_code2string (flavors, attr->flavor);
conf2 (dimension);
conf2 (dummy);
conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
break;
case FL_VARIABLE:
+ break;
+
case FL_NAMELIST:
+ conf2 (result);
break;
case FL_PROCEDURE:
- /* Conflicts with INTENT will be checked at resolution stage,
- see "resolve_fl_procedure". */
+ /* Conflicts with INTENT, SAVE and RESULT will be checked
+ at resolution stage, see "resolve_fl_procedure". */
if (attr->subroutine)
{
+ a1 = subroutine;
conf2 (target);
conf2 (allocatable);
- conf2 (result);
+ conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (in_namelist);
conf2 (dimension);
conf2 (function);
conf2 (threadprivate);
}
+ if (!attr->proc_pointer)
+ conf2 (in_common);
+
switch (attr->proc)
{
case PROC_ST_FUNCTION:
- conf2 (in_common);
conf2 (dummy);
break;
case PROC_DUMMY:
conf2 (result);
- conf2 (in_common);
conf2 (threadprivate);
break;
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+ conf2 (result);
if (attr->intent != INTENT_UNKNOWN)
{
conf2 (in_common);
conf2 (value);
conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (threadprivate);
conf2 (value);
conf2 (is_bind_c);
+ conf2 (result);
break;
default:
}
+gfc_try
+gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
+ locus *where ATTRIBUTE_UNUSED)
+{
+ attr->ext_attr |= 1 << ext_attr;
+ return SUCCESS;
+}
+
+
/* Called from decl.c (attr_decl1) to check attributes, when declared
separately. */
gfc_try
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
-
if (check_used (attr, NULL, where))
return FAILURE;
return check_conflict (attr, NULL, where);
}
+
gfc_try
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
return FAILURE;
}
- if (attr->save == SAVE_EXPLICIT)
+ if (attr->save == SAVE_EXPLICIT && !attr->vtab)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
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)
{
/* Duplicate attribute already checked for. */
attr->in_common = 1;
- if (check_conflict (attr, name, where) == FAILURE)
- return FAILURE;
-
- if (attr->flavor == FL_VARIABLE)
- return SUCCESS;
-
- return gfc_add_flavor (attr, FL_VARIABLE, name, where);
+ return check_conflict (attr, name, where);
}
}
+gfc_try
+gfc_add_abstract (symbol_attribute* attr, locus* where)
+{
+ if (attr->abstract)
+ {
+ duplicate_attr ("ABSTRACT", where);
+ return FAILURE;
+ }
+
+ attr->abstract = 1;
+ return SUCCESS;
+}
+
+
/* Flavors are special because some flavors are not what Fortran
considers attributes and can be reaffirmed multiple times. */
const char *name, locus *where)
{
- if (attr->access == ACCESS_UNKNOWN)
+ if (attr->access == ACCESS_UNKNOWN
+ || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
{
attr->access = access;
return check_conflict (attr, name, where);
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor flavor;
+ bt type;
if (where == NULL)
where = &gfc_current_locus;
- if (sym->ts.type != BT_UNKNOWN)
+ if (sym->result)
+ type = sym->result->ts.type;
+ else
+ type = sym->ts.type;
+
+ if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
+ type = sym->ns->proc_name->ts.type;
+
+ if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
{
- const char *msg = "Symbol '%s' at %L already has basic type of %s";
- if (!(sym->ts.type == ts->type
- && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
- || gfc_notification_std (GFC_STD_GNU) == ERROR
- || pedantic)
- {
- gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
- return FAILURE;
- }
- else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
- gfc_basic_typename (sym->ts.type)) == FAILURE)
- return FAILURE;
+ gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+ where, gfc_basic_typename (type));
+ return FAILURE;
+ }
+
+ if (sym->attr.procedure && sym->ts.interface)
+ {
+ gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+ sym->name, where, gfc_basic_typename (ts->type));
+ return FAILURE;
}
flavor = sym->attr.flavor;
{
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;
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))
+ && 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;
}
p->name = gfc_get_string (name);
p->loc = gfc_current_locus;
+ p->ts.type = BT_UNKNOWN;
*component = p;
return SUCCESS;
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);
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);
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
- not found or the components are private. */
+ not found or the components are private. If noaccess is set, no access
+ checks are done. */
gfc_component *
-gfc_find_component (gfc_symbol *sym, const char *name)
+gfc_find_component (gfc_symbol *sym, const char *name,
+ bool noaccess, bool silent)
{
gfc_component *p;
&& 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)
return p;
}
- if (p == NULL)
+ if (p == NULL && !silent)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else if (sym->attr.use_assoc)
+ else if (sym->attr.use_assoc && !noaccess)
{
- if (p->access == ACCESS_PRIVATE)
- {
- 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->access != ACCESS_PUBLIC && sym->component_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))
{
- gfc_error ("All components of '%s' are PRIVATE in structure"
- " constructor at %C", sym->name);
+ if (!silent)
+ gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
+ name, sym->name);
return NULL;
}
}
}
-/* Set component attributes from a standard symbol attribute structure. */
-
-void
-gfc_set_component_attr (gfc_component *c, symbol_attribute *attr)
-{
-
- c->dimension = attr->dimension;
- c->pointer = attr->pointer;
- c->allocatable = attr->allocatable;
- c->access = attr->access;
-}
-
-
-/* Get a standard symbol attribute structure given the component
- structure. */
-
-void
-gfc_get_component_attr (symbol_attribute *attr, gfc_component *c)
-{
-
- gfc_clear_attr (attr);
- attr->dimension = c->dimension;
- attr->pointer = c->pointer;
- attr->allocatable = c->allocatable;
- attr->access = c->access;
-}
-
-
/******************** Statement label management ********************/
/* Comparison function for statement labels, used for managing the
gfc_get_st_label (int labelno)
{
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;
/* 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;
}
{
gfc_namespace *ns;
gfc_typespec *ts;
- gfc_intrinsic_op in;
+ int in;
int i;
ns = XCNEW (gfc_namespace);
ns->sym_root = NULL;
ns->uop_root = NULL;
+ ns->tb_sym_root = NULL;
ns->finalizers = NULL;
ns->default_access = ACCESS_UNKNOWN;
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++)
}
+/* 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;
+}
+
+
/* 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. */
So if the return value is nonzero, then an error was issued. */
int
-gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
+gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
+ bool allow_subroutine)
{
gfc_symtree *st;
gfc_symbol *p;
}
p = st->n.sym;
-
if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
- && !(ns->proc_name
- && ns->proc_name->attr.if_source == IFSRC_IFBODY
- && (ns->has_import_set || p->attr.imported)))
+ && !(allow_subroutine && p->attr.subroutine)
+ && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && (ns->has_import_set || p->attr.imported)))
{
/* Symbol is from another namespace. */
gfc_error ("Symbol '%s' at %C has already been host associated",
gfc_symtree *st;
int i;
- i = gfc_get_sym_tree (name, ns, &st);
+ i = gfc_get_sym_tree (name, ns, &st, false);
if (i != 0)
return i;
int i;
i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+
if (st != NULL)
{
save_symbol_data (st->n.sym);
}
}
- return gfc_get_sym_tree (name, gfc_current_ns, result);
+ return gfc_get_sym_tree (name, gfc_current_ns, result, false);
}
gfc_undo_symbols (void)
{
gfc_symbol *p, *q, *old;
+ tentative_tbp *tbp, *tbq;
for (p = changed_syms; p; p = q)
{
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
}
changed_syms = NULL;
+
+ for (tbp = tentative_tbp_list; tbp; tbp = tbq)
+ {
+ tbq = tbp->next;
+ /* Procedure is already marked `error' by default. */
+ gfc_free (tbp);
+ }
+ tentative_tbp_list = NULL;
}
gfc_commit_symbols (void)
{
gfc_symbol *p, *q;
+ tentative_tbp *tbp, *tbq;
for (p = changed_syms; p; p = q)
{
free_old_symbol (p);
}
changed_syms = NULL;
+
+ for (tbp = tentative_tbp_list; tbp; tbp = tbq)
+ {
+ tbq = tbp->next;
+ tbp->proc->error = 0;
+ gfc_free (tbp);
+ }
+ tentative_tbp_list = NULL;
}
}
+/* Recursively free trees containing type-bound procedures. */
+
+static void
+free_tb_tree (gfc_symtree *t)
+{
+ if (t == NULL)
+ return;
+
+ free_tb_tree (t->left);
+ free_tb_tree (t->right);
+
+ /* TODO: Free type-bound procedure structs themselves; probably needs some
+ sort of ref-counting mechanism. */
+
+ gfc_free (t);
+}
+
+
/* Recursive function that deletes an entire tree and all the common
head structures it points to. */
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 the derived type list. */
-static void
+void
gfc_free_dt_list (void)
{
gfc_dt_list *dt, *n;
}
+/* 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_charlen *old_cl)
+{
+ 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)
+ {
+ 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;
+ }
+
+ 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)
+{
+ gfc_charlen *cl2;
+
+ for (; cl != end; cl = cl2)
+ {
+ gcc_assert (cl);
+
+ cl2 = cl->next;
+ gfc_free_expr (cl->length);
+ gfc_free (cl);
+ }
+}
+
+
/* 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. */
void
gfc_free_namespace (gfc_namespace *ns)
{
- gfc_charlen *cl, *cl2;
gfc_namespace *p, *q;
- gfc_intrinsic_op i;
+ int i;
if (ns == NULL)
return;
free_sym_tree (ns->sym_root);
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);
-
- for (cl = ns->cl_list; cl; cl = cl2)
- {
- cl2 = cl->next;
- gfc_free_expr (cl->length);
- gfc_free (cl);
- }
-
+ gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
gfc_free_equiv (ns->equiv);
gfc_free_equiv_lists (ns->equiv_lists);
+ gfc_free_use_stmts (ns->use_stmts);
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
gfc_free_interface (ns->op[i]);
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;
}
if (sym->attr.in_common
|| sym->attr.dummy
+ || sym->attr.result
|| sym->attr.flavor != FL_VARIABLE)
return;
/* Automatic objects are not saved. */
void
gfc_save_all (gfc_namespace *ns)
{
-
gfc_traverse_ns (ns, save_symbol);
}
{
/* The components cannot be pointers (fortran sense).
J3/04-007, Section 15.2.3, C1505. */
- if (curr_comp->pointer != 0)
+ if (curr_comp->attr.pointer != 0)
{
gfc_error ("Component '%s' at %L cannot have the "
"POINTER attribute because it is a member "
retval = FAILURE;
}
+ if (curr_comp->attr.proc_pointer != 0)
+ {
+ gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
+ " of the BIND(C) derived type '%s' at %L", curr_comp->name,
+ &curr_comp->loc, derived_sym->name,
+ &derived_sym->declared_at);
+ retval = FAILURE;
+ }
+
/* The components cannot be allocatable.
J3/04-007, Section 15.2.3, C1505. */
- if (curr_comp->allocatable != 0)
+ if (curr_comp->attr.allocatable != 0)
{
gfc_error ("Component '%s' at %L cannot have the "
"ALLOCATABLE attribute because it is a member "
/* 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), curr_comp->name,
- &(curr_comp->loc));
+ is_c_interop = verify_c_interop (&(curr_comp->ts));
if (is_c_interop != SUCCESS)
{
/* 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->ts.u.derived = tmp_sym->ts.u.derived;
tmp_sym->value->value.constructor = gfc_get_constructor ();
+ tmp_sym->value->value.constructor->expr = gfc_get_expr ();
+ tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
+ tmp_sym->value->value.constructor->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;
c_ptr_in = "gfc_cptr__";
else
c_ptr_in = c_ptr_name;
- gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
+ gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
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. */
if (f_ptr_name != NULL)
f_ptr_out = f_ptr_name;
- gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
+ gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
if (shape_param_name != NULL)
shape_param = shape_param_name;
- gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
+ gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
add_formal_arg (head, tail, formal_arg, param_sym);
}
+
/* Add a procedure interface to the given symbol (i.e., store a
reference to the list of formal arguments). */
sym->attr.if_source = source;
}
+
/* Copy the formal args from an existing symbol, src, into a new
symbol, dest. New formal args are created, and the description of
each arg is set according to the existing ones. This function is
args based on the args of a given named interface. */
void
-copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
formal_arg->sym->attr = curr_arg->sym->attr;
formal_arg->sym->ts = curr_arg->sym->ts;
formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+ /* 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
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
+void
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_intrinsic_arg *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* 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.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.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
gfc_current_ns = parent_ns;
}
+
+void
+gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_formal_arglist *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ /* TODO: gfc_current_ns->proc_name = dest;*/
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->ts = curr_arg->sym->ts;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+ /* 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
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ dest->formal = head;
+ dest->attr.if_source = IFSRC_DECL;
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
- if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE)
+ if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
return;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
return;
/* Create the sym tree in the current ns. */
- gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
if (tmp_symtree)
tmp_sym = tmp_symtree->n.sym;
else
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_int_expr (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);
index = get_c_kind ("c_ptr", c_interop_kinds_table);
tmp_comp->ts.kind = c_interop_kinds_table[index].value;
- tmp_comp->pointer = 0;
- tmp_comp->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;
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);
tmp_sym->result = tmp_sym;
tmp_sym->attr.external = 1;
tmp_sym->attr.use_assoc = 0;
+ tmp_sym->attr.pure = 1;
tmp_sym->attr.if_source = IFSRC_UNKNOWN;
tmp_sym->attr.proc = PROC_UNKNOWN;
}
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);
/* Everything is ok. */
return SUCCESS;
}
+
+
+/* Construct a typebound-procedure structure. Those are stored in a tentative
+ list and marked `error' until symbols are committed. */
+
+gfc_typebound_proc*
+gfc_get_typebound_proc (void)
+{
+ gfc_typebound_proc *result;
+ tentative_tbp *list_node;
+
+ result = XCNEW (gfc_typebound_proc);
+ result->error = 1;
+
+ list_node = XCNEW (tentative_tbp);
+ list_node->next = tentative_tbp_list;
+ list_node->proc = result;
+ tentative_tbp_list = list_node;
+
+ return result;
+}
+
+
+/* Get the super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ gcc_assert (derived->components);
+ gcc_assert (derived->components->ts.type == BT_DERIVED);
+ gcc_assert (derived->components->ts.u.derived);
+
+ return derived->components->ts.u.derived;
+}
+
+
+/* Get the ultimate super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ derived = gfc_get_derived_super_type (derived);
+
+ if (derived->attr.extension)
+ return gfc_get_ultimate_derived_super_type (derived);
+ else
+ return derived;
+}
+
+
+/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
+
+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)
+{
+ 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);
+ 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);
+
+ 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);
+
+ else if (is_class1 && is_class2)
+ return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->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.class_pointer = attr->pointer;
+ 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->attr.access = ACCESS_PRIVATE;
+ 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);
+ vtype->attr.access = ACCESS_PRIVATE;
+
+ /* 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. */
+
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, bool uop,
+ locus* where)
+{
+ 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)
+ {
+ /* 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);
+ }
+
+ /* 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);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+ super-type hierarchy. */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+ gfc_intrinsic_op op, bool noaccess,
+ locus* where)
+{
+ 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;
+ }
+
+ /* 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 gfc_find_typebound_intrinsic_op (super_type, t, op,
+ noaccess, where);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* 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_symtree *result;
+
+ result = gfc_find_symtree (*root, name);
+ if (!result)
+ {
+ result = gfc_new_symtree (root, name);
+ gcc_assert (result);
+ result->n.tb = NULL;
+ }
+
+ return result;
+}
OSDN Git Service
