/* 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
#include "flags.h"
#include "gfortran.h"
#include "parse.h"
+#include "match.h"
/* Strings for all symbol attributes. We use these for dumping the
{
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
/* Prepare for a new implicit range. Sets flags in new_flag[]. */
-try
+gfc_try
gfc_add_new_implicit_range (int c1, int c2)
{
int i;
/* Add a matched implicit range for gfc_set_implicit(). Check if merging
the new implicit types back into the existing types will work. */
-try
+gfc_try
gfc_merge_new_implicit (gfc_typespec *ts)
{
int i;
{
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;
letter of its name. Fails if the letter in question has no default
type. */
-try
+gfc_try
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
gfc_typespec *ts;
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. */
{
/* Dummy args to a BIND(C) routine may not be interoperable if
they are implicitly typed. */
- gfc_warning_now ("Implicity declared variable '%s' at %L may not "
+ gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
"be C interoperable but it is a dummy argument to "
"the BIND(C) procedure '%s' at %L", sym->name,
&(sym->declared_at), sym->ns->proc_name->name,
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);
goto conflict_std;\
}
-static try
+static gfc_try
check_conflict (symbol_attribute *attr, const char *name, locus *where)
{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
*intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
*intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
*allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
- *private = "PRIVATE", *recursive = "RECURSIVE",
+ *privat = "PRIVATE", *recursive = "RECURSIVE",
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
- *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
+ *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
- *volatile_ = "VOLATILE", *protected = "PROTECTED",
+ *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
static const char *threadprivate = "THREADPRIVATE";
if (attr->optional)
a1 = optional;
if (attr->access == ACCESS_PRIVATE)
- a1 = private;
+ a1 = privat;
if (attr->access == ACCESS_PUBLIC)
- a1 = public;
+ a1 = publik;
if (attr->intent != INTENT_UNKNOWN)
a1 = intent;
goto conflict;
case FL_PROCEDURE:
- if (attr->proc_pointer)
- break;
- a1 = gfc_code2string (flavors, attr->flavor);
- a2 = save;
- goto conflict;
-
+ /* Conflicts between SAVE and PROCEDURE will be checked at
+ resolution stage, see "resolve_fl_procedure". */
case FL_VARIABLE:
case FL_NAMELIST:
default:
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);
goto conflict;
}
- conf (protected, intrinsic)
- conf (protected, external)
- conf (protected, in_common)
+ conf (is_protected, intrinsic)
+ conf (is_protected, external)
+ conf (is_protected, in_common)
conf (volatile_, intrinsic)
conf (volatile_, external)
conf (procedure, allocatable)
conf (procedure, dimension)
conf (procedure, intrinsic)
- conf (procedure, protected)
+ conf (procedure, is_protected)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
conf2 (dummy);
conf2 (volatile_);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
{
- a2 = attr->access == ACCESS_PUBLIC ? public : private;
+ a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
name, where);
return FAILURE;
break;
case FL_VARIABLE:
+ break;
+
case FL_NAMELIST:
+ conf2 (result);
break;
case FL_PROCEDURE:
- if (!attr->proc_pointer)
- conf2 (intent);
+ /* 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 (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 (subroutine);
conf2 (entry);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
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. */
-try
+gfc_try
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
-
if (check_used (attr, NULL, where))
return FAILURE;
return check_conflict (attr, NULL, where);
}
-try
+
+gfc_try
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_optional (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_pointer (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, name, where))
return FAILURE;
- if (attr->protected)
+ if (attr->is_protected)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate PROTECTED attribute specified at %L",
return FAILURE;
}
- attr->protected = 1;
+ attr->is_protected = 1;
return check_conflict (attr, name, where);
}
-try
+gfc_try
gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_save (symbol_attribute *attr, const char *name, 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",
}
-try
+gfc_try
gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
}
-try
+gfc_try
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_target (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_in_common (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);
}
-try
+gfc_try
gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_elemental (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_pure (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_recursive (symbol_attribute *attr, locus *where)
{
}
-try
+gfc_try
gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_proc (symbol_attribute *attr, const char *name, locus *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. */
-try
+gfc_try
gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
locus *where)
{
}
-try
+gfc_try
gfc_add_procedure (symbol_attribute *attr, procedure_type t,
const char *name, locus *where)
{
}
-try
+gfc_try
gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
{
/* No checks for use-association in public and private statements. */
-try
+gfc_try
gfc_add_access (symbol_attribute *attr, gfc_access access,
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);
/* Set the is_bind_c field for the given symbol_attribute. */
-try
+gfc_try
gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
int is_proc_lang_bind_spec)
{
}
-try
+/* Set the extension field for the given symbol_attribute. */
+
+gfc_try
+gfc_add_extension (symbol_attribute *attr, locus *where)
+{
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (attr->extension)
+ gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
+ else
+ attr->extension = 1;
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
+ == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
gfc_formal_arglist * formal, locus *where)
{
/* Add a type to a symbol. */
-try
+gfc_try
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;
/* Check for missing attributes in the new symbol. Currently does
nothing, but it's not clear that it is unnecessary yet. */
-try
+gfc_try
gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
locus *where ATTRIBUTE_UNUSED)
{
attributes have a lot of side-effects but cannot be present given
where we are called from, so we ignore some bits. */
-try
+gfc_try
gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
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->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
- if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+ if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
goto fail;
if (src->save && gfc_add_save (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
already present. On success, the component pointer is modified to
point to the additional component structure. */
-try
+gfc_try
gfc_add_component (gfc_symbol *sym, const char *name,
gfc_component **component)
{
tail = p;
}
+ if (sym->attr.extension
+ && 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.u.derived->declared_at);
+ return FAILURE;
+ }
+
/* Allocate a new component. */
p = gfc_get_component ();
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;
if (strcmp (p->name, name) == 0)
break;
- if (p == NULL)
+ if (p == NULL
+ && sym->attr.extension
+ && sym->components->ts.type == BT_DERIVED)
+ {
+ 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 && !silent)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else
+
+ else if (sym->attr.use_assoc && !noaccess)
{
- if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
- || p->access == ACCESS_PRIVATE))
+ if (p->attr.access == ACCESS_PRIVATE)
{
- gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
- name, sym->name);
- p = NULL;
+ 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;
}
}
}
-/* 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;
}
updating the unknown state. Returns FAILURE if something goes
wrong. */
-try
+gfc_try
gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
{
gfc_sl_type label_type;
int labelno;
- try rc;
+ gfc_try rc;
if (lp == NULL)
return SUCCESS;
{
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. */
save_symbol_data (gfc_symbol *sym)
{
- if (sym->new || sym->old_symbol != NULL)
+ if (sym->gfc_new || sym->old_symbol != NULL)
return;
sym->old_symbol = XCNEW (gfc_symbol);
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->old_symbol = NULL;
p->tlink = changed_syms;
p->mark = 1;
- p->new = 1;
+ p->gfc_new = 1;
changed_syms = p;
st = gfc_new_symtree (&ns->sym_root, name);
}
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)
{
q = p->tlink;
- if (p->new)
+ 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)
{
q = p->tlink;
p->tlink = NULL;
p->mark = 0;
- p->new = 0;
+ p->gfc_new = 0;
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;
}
sym->tlink = NULL;
sym->mark = 0;
- sym->new = 0;
+ sym->gfc_new = 0;
free_old_symbol (sym);
}
+/* 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->left);
free_uop_tree (uop_tree->right);
- gfc_free_interface (uop_tree->n.uop->operator);
-
+ 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;
{
if (el)
{
- --el->procedure->refs;
- if (!el->procedure->refs)
- gfc_free_symbol (el->procedure);
+ if (el->proc_sym)
+ {
+ --el->proc_sym->refs;
+ if (!el->proc_sym->refs)
+ gfc_free_symbol (el->proc_sym);
+ }
gfc_free (el);
}
}
+/* 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->operator[i]);
+ gfc_free_interface (ns->op[i]);
gfc_free_data (ns->data);
p = ns->contained;
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);
}
for such. If an error occurs, the errors are reported here, allowing for
multiple errors to be handled for a single derived type. */
-try
+gfc_try
verify_bind_c_derived_type (gfc_symbol *derived_sym)
{
gfc_component *curr_comp = NULL;
- try is_c_interop = FAILURE;
- try retval = SUCCESS;
+ gfc_try is_c_interop = FAILURE;
+ gfc_try retval = SUCCESS;
if (derived_sym == NULL)
gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
{
/* 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)
{
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
-static try
+static gfc_try
gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
const char *module_name)
{
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
if (ptr_id == ISOCBINDING_NULL_PTR)
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.u.derived == NULL)
{
/* This can occur if the user forgot to declare c_ptr or
c_funptr and they're trying to use one of the procedures
? "_gfortran_iso_c_binding_c_ptr"
: "_gfortran_iso_c_binding_c_funptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
- tmp_sym->value->ts.derived = tmp_sym->ts.derived;
+ 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);
+ 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;
}
return new_symtree->n.sym;
}
+
+/* Check that a symbol is already typed. If strict is not set, an untyped
+ symbol is acceptable for non-standard-conforming mode. */
+
+gfc_try
+gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
+ bool strict, locus where)
+{
+ gcc_assert (sym);
+
+ if (gfc_matching_prefix)
+ return SUCCESS;
+
+ /* Check for the type and try to give it an implicit one. */
+ if (sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (sym, 0, ns) == FAILURE)
+ {
+ if (strict)
+ {
+ gfc_error ("Symbol '%s' is used before it is typed at %L",
+ sym->name, &where);
+ return FAILURE;
+ }
+
+ if (gfc_notify_std (GFC_STD_GNU,
+ "Extension: Symbol '%s' is used before"
+ " it is typed at %L", sym->name, &where) == FAILURE)
+ return FAILURE;
+ }
+
+ /* 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
