/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
{
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
/* 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 '%s'",sym->name);
+ 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->cl)
- {
- sym->ts.cl = gfc_get_charlen ();
- *sym->ts.cl = *ts->cl;
- }
+ if (ts->type == BT_CHARACTER && ts->u.cl)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
if (sym->attr.is_bind_c == 1)
{
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);
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);
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)
{
conf2 (target);
conf2 (allocatable);
- conf2 (result);
conf2 (in_namelist);
conf2 (dimension);
conf2 (function);
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+ conf2 (result);
if (attr->intent != INTENT_UNKNOWN)
{
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_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;
- }
- if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
- gfc_basic_typename (sym->ts.type)) == FAILURE)
- return FAILURE;
- if (gfc_option.warn_surprising)
- gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
+ 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;
if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
goto fail;
if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
- goto fail;
+ goto fail;
is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
if (src->is_bind_c
}
if (sym->attr.extension
- && gfc_find_component (sym->components->ts.derived, name, true, true))
+ && gfc_find_component (sym->components->ts.u.derived, name, true, true))
{
gfc_error ("Component '%s' at %C already in the parent type "
- "at %L", name, &sym->components->ts.derived->declared_at);
+ "at %L", name, &sym->components->ts.u.derived->declared_at);
return FAILURE;
}
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);
&& 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)
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++)
st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
- st->typebound = NULL;
gfc_insert_bbt (root, st, compare_symtree);
return st;
}
+/* 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. */
gfc_free_namespace (gfc_namespace *ns)
{
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);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
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. */
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->attr.allocatable != 0)
/* 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;
+ 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). */
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);
- copy_formal_args (formal_arg->sym, curr_arg->sym);
+ 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
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);
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;
}
}
+/* 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*
gcc_assert (derived->components);
gcc_assert (derived->components->ts.type == BT_DERIVED);
- gcc_assert (derived->components->ts.derived);
+ gcc_assert (derived->components->ts.u.derived);
+
+ return derived->components->ts.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;
+}
- return derived->components->ts.derived;
+
+/* 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 by name for a derived-type (looking recursively
- through the super-types). */
+/* 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)
+ const char* name, bool noaccess, locus* where)
{
- gfc_symtree* res;
+ 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. */
- gcc_assert (derived->f2k_derived);
- res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
- if (res && res->typebound)
+ 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->typebound->access == ACCESS_PRIVATE)
+ && res->access == ACCESS_PRIVATE)
{
- gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+ if (where)
+ gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_op2string (op), derived->name, where);
if (t)
*t = FAILURE;
}
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
- return gfc_find_typebound_proc (super_type, t, name, noaccess);
+
+ 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;
+}