/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "parse.h"
#include "match.h"
+#include "constructor.h"
/* Strings for all symbol attributes. We use these for dumping the
{
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_gsymbol *gfc_gsym_root = NULL;
-static gfc_symbol *changed_syms = NULL;
+gfc_symbol *changed_syms = 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)
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
- *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
+ *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+ *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
+ *contiguous = "CONTIGUOUS";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
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_std (allocatable, function, GFC_STD_F2003);
conf (in_common, dummy);
conf (in_common, allocatable);
+ conf (in_common, codimension);
conf (in_common, result);
conf (dummy, result);
conf (in_equivalence, use_assoc);
+ conf (in_equivalence, codimension);
conf (in_equivalence, dummy);
conf (in_equivalence, target);
conf (in_equivalence, pointer);
conf (is_bind_c, cray_pointer);
conf (is_bind_c, cray_pointee);
+ conf (is_bind_c, codimension);
conf (is_bind_c, allocatable);
conf (is_bind_c, elemental);
/* Cray pointer/pointee conflicts. */
conf (cray_pointer, cray_pointee);
conf (cray_pointer, dimension);
+ conf (cray_pointer, codimension);
+ conf (cray_pointer, contiguous);
conf (cray_pointer, pointer);
conf (cray_pointer, target);
conf (cray_pointer, allocatable);
conf (cray_pointer, entry);
conf (cray_pointee, allocatable);
+ conf (cray_pointer, contiguous);
+ conf (cray_pointer, codimension);
conf (cray_pointee, intent);
conf (cray_pointee, optional);
conf (cray_pointee, dummy);
conf (data, function);
conf (data, result);
conf (data, allocatable);
- conf (data, use_assoc);
conf (value, pointer)
conf (value, allocatable)
conf (value, function)
conf (value, volatile_)
conf (value, dimension)
+ conf (value, codimension)
conf (value, external)
+ conf (codimension, result)
+
if (attr->value
&& (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
{
}
conf (is_protected, intrinsic)
- conf (is_protected, external)
conf (is_protected, in_common)
+ conf (asynchronous, intrinsic)
+ conf (asynchronous, external)
+
conf (volatile_, intrinsic)
conf (volatile_, external)
conf (procedure, allocatable)
conf (procedure, dimension)
+ conf (procedure, codimension)
conf (procedure, intrinsic)
- conf (procedure, is_protected)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
+ conf (procedure, asynchronous)
conf (procedure, entry)
a1 = gfc_code2string (flavors, attr->flavor);
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
+ conf2 (codimension);
conf2 (dimension);
conf2 (dummy);
conf2 (volatile_);
+ conf2 (asynchronous);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
if (attr->subroutine)
{
+ a1 = subroutine;
conf2 (target);
conf2 (allocatable);
+ conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (in_namelist);
+ conf2 (codimension);
conf2 (dimension);
conf2 (function);
conf2 (threadprivate);
conf2 (function);
conf2 (subroutine);
conf2 (entry);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
conf2 (in_common);
conf2 (value);
conf2 (volatile_);
+ conf2 (asynchronous);
conf2 (threadprivate);
conf2 (value);
conf2 (is_bind_c);
+ conf2 (codimension);
conf2 (result);
break;
}
+gfc_try
+gfc_add_ext_attribute (symbol_attribute *attr, 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)
{
gfc_try
+gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ if (attr->codimension)
+ {
+ duplicate_attr ("CODIMENSION", where);
+ return FAILURE;
+ }
+
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ {
+ gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
+ "at %L", name, where);
+ return FAILURE;
+ }
+
+ attr->codimension = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
gfc_try
+gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ attr->contiguous = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
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",
{
/* No check_used needed as 11.2.1 of the F2003 standard allows
that the local identifier made accessible by a use statement can be
- given a VOLATILE attribute. */
+ given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
if (gfc_notify_std (GFC_STD_LEGACY,
gfc_try
+gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
+{
+ /* No check_used needed as 11.2.1 of the F2003 standard allows
+ that the local identifier made accessible by a use statement can be
+ given a ASYNCHRONOUS attribute. */
+
+ if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
+ if (gfc_notify_std (GFC_STD_LEGACY,
+ "Duplicate ASYNCHRONOUS attribute specified at %L",
+ where) == FAILURE)
+ return FAILURE;
+
+ attr->asynchronous = 1;
+ attr->asynchronous_ns = gfc_current_ns;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
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.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));
+ gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+ sym->name, where, gfc_basic_typename (ts->type));
return FAILURE;
}
{
int is_proc_lang_bind_spec;
+ /* In line with the other attributes, we only add bits but do not remove
+ them; cf. also PR 41034. */
+ dest->ext_attr |= src->ext_attr;
+
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
+ goto fail;
+ if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->optional && gfc_add_optional (dest, where) == FAILURE)
goto fail;
if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->threadprivate
&& gfc_add_threadprivate (dest, NULL, where) == FAILURE)
goto fail;
if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
goto fail;
if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
- goto fail;
+ goto fail;
is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
if (src->is_bind_c
}
if (sym->attr.extension
- && gfc_find_component (sym->components->ts.derived, name, true, true))
+ && gfc_find_component (sym->components->ts.u.derived, name, true, true))
{
gfc_error ("Component '%s' at %C already in the parent type "
- "at %L", name, &sym->components->ts.derived->declared_at);
+ "at %L", name, &sym->components->ts.u.derived->declared_at);
return FAILURE;
}
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)
else if (sym->attr.use_assoc && !noaccess)
{
- if (p->attr.access == ACCESS_PRIVATE)
+ bool is_parent_comp = sym->attr.extension && (p == sym->components);
+ if (p->attr.access == ACCESS_PRIVATE ||
+ (p->attr.access != ACCESS_PUBLIC
+ && sym->component_access == ACCESS_PRIVATE
+ && !is_parent_comp))
{
if (!silent)
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
return NULL;
}
-
- /* If there were components given and all components are private, error
- out at this place. */
- if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
- {
- if (!silent)
- gfc_error ("All components of '%s' are PRIVATE in structure"
- " constructor at %C", sym->name);
- return NULL;
- }
}
return p;
gfc_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;
}
+/* Decrease the reference counter and free memory when we reach zero. */
+void
+gfc_release_symbol (gfc_symbol *sym)
+{
+ if (sym == NULL)
+ return;
+
+ if (sym->formal_ns != NULL && sym->refs == 2)
+ {
+ /* As formal_ns contains a reference to sym, delete formal_ns just
+ before the deletion of sym. */
+ gfc_namespace *ns = sym->formal_ns;
+ sym->formal_ns = NULL;
+ gfc_free_namespace (ns);
+ }
+
+ sym->refs--;
+ if (sym->refs > 0)
+ return;
+
+ gcc_assert (sym->refs == 0);
+ gfc_free_symbol (sym);
+}
+
+
/* Allocate and initialize a new symbol node. */
gfc_symbol *
/* Clear the ptrs we may need. */
p->common_block = NULL;
p->f2k_derived = NULL;
+ p->assoc = NULL;
return p;
}
}
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+ selector on the stack. If yes, replace it by the corresponding temporary. */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+ gfc_select_type_stack *stack = select_type_stack;
+ for (; stack; stack = stack->prev)
+ if ((*st)->n.sym == stack->selector && stack->tmp)
+ *st = stack->tmp;
+}
+
+
+/* Look for a symtree in the current procedure -- that is, go up to
+ parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
+
+gfc_symtree*
+gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
+{
+ while (ns)
+ {
+ gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ return st;
+
+ if (!ns->construct_entities)
+ break;
+ ns = ns->parent;
+ }
+
+ return NULL;
+}
+
+
/* Search for a symtree starting in the current namespace, resorting to
any parent namespaces if requested by a nonzero parent_flag.
Returns nonzero if the name is ambiguous. */
st = gfc_find_symtree (ns->sym_root, name);
if (st != NULL)
{
+ select_type_insert_tmp (&st);
+
*result = st;
/* Ambiguous generic interfaces are permitted, as long
as the specific interfaces are different. */
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);
}
if (lsym->attr.allocatable && rsym->attr.pointer)
return 1;
+ /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
+ and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
+ checked above. */
+ if (lsym->attr.target && rsym->attr.target
+ && ((lsym->attr.dummy && !lsym->attr.contiguous
+ && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
+ || (rsym->attr.dummy && !rsym->attr.contiguous
+ && (!rsym->attr.dimension
+ || rsym->as->type == AS_ASSUMED_SHAPE))))
+ return 1;
+
return 0;
}
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
gfc_delete_symtree (&p->ns->sym_root, p->name);
- p->refs--;
- if (p->refs < 0)
- gfc_internal_error ("gfc_undo_symbols(): Negative refs");
- if (p->refs == 0)
- gfc_free_symbol (p);
+ gfc_release_symbol (p);
continue;
}
}
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);
}
static void
free_sym_tree (gfc_symtree *sym_tree)
{
- gfc_namespace *ns;
- gfc_symbol *sym;
-
if (sym_tree == NULL)
return;
free_sym_tree (sym_tree->left);
free_sym_tree (sym_tree->right);
- sym = sym_tree->n.sym;
-
- sym->refs--;
- if (sym->refs < 0)
- gfc_internal_error ("free_sym_tree(): Negative refs");
-
- if (sym->formal_ns != NULL && sym->refs == 1)
- {
- /* As formal_ns contains a reference to sym, delete formal_ns just
- before the deletion of sym. */
- ns = sym->formal_ns;
- sym->formal_ns = NULL;
- gfc_free_namespace (ns);
- }
- else if (sym->refs == 0)
- {
- /* Go ahead and delete the symbol. */
- gfc_free_symbol (sym);
- }
-
+ gfc_release_symbol (sym_tree->n.sym);
gfc_free (sym_tree);
}
{
if (el)
{
- if (el->proc_sym)
- {
- --el->proc_sym->refs;
- if (!el->proc_sym->refs)
- gfc_free_symbol (el->proc_sym);
- }
-
+ gfc_release_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. */
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;
}
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
{
{
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym;
+ gfc_constructor *c;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
if (ptr_id == ISOCBINDING_NULL_PTR)
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.u.derived == NULL)
{
/* This can occur if the user forgot to declare c_ptr or
c_funptr and they're trying to use one of the procedures
? "_gfortran_iso_c_binding_c_ptr"
: "_gfortran_iso_c_binding_c_funptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
tmp_sym->value = gfc_get_expr ();
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
- tmp_sym->value->ts.derived = tmp_sym->ts.derived;
- /* Create a constructor with no expr, that way we can recognize if the user
- tries to call the structure constructor for one of the iso_c_binding
- derived types during resolution (resolve_structure_cons). */
- tmp_sym->value->value.constructor = gfc_get_constructor ();
+ tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
+ gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
+ c = gfc_constructor_first (tmp_sym->value->value.constructor);
+ c->expr = gfc_get_expr ();
+ c->expr->expr_type = EXPR_NULL;
+ c->expr->ts.is_iso_c = 1;
/* Must declare c_null_ptr and c_null_funptr as having the
PARAMETER attribute so they can be used in init expressions. */
tmp_sym->attr.flavor = FL_PARAMETER;
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
param_sym->as->upper[i] = NULL;
}
param_sym->as->rank = 1;
- param_sym->as->lower[0] = gfc_int_expr (1);
+ param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
/* The extent is unknown until we get it. The length give us
the rank the incoming pointer. */
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
gfc_current_ns = parent_ns;
}
+
void
-copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
/* 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 = curr_arg->sym->attr;
- formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- copy_formal_args (formal_arg->sym, curr_arg->sym);*/
+ 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
#define NAMED_CHARKNDCST(a,b,c) case a :
#include "iso-c-binding.def"
- tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
+ tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c_interop_kinds_table[s].value);
/* Initialize an integer constant expression node. */
tmp_sym->attr.flavor = FL_PARAMETER;
/* Initialize an integer constant expression node for the
length of the character. */
- tmp_sym->value = gfc_get_expr ();
- tmp_sym->value->expr_type = EXPR_CONSTANT;
- tmp_sym->value->ts.type = BT_CHARACTER;
- tmp_sym->value->ts.kind = gfc_default_character_kind;
- tmp_sym->value->where = gfc_current_locus;
+ tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, NULL, 1);
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
- tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
= (gfc_char_t) c_interop_kinds_table[s].value;
- tmp_sym->value->value.character.string[1] = '\0';
- tmp_sym->ts.cl = gfc_get_charlen ();
- tmp_sym->ts.cl->length = gfc_int_expr (1);
+ tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
tmp_sym->attr.referenced = 1;
- tmp_sym->ts.derived = tmp_sym;
+ tmp_sym->ts.u.derived = tmp_sym;
/* Add the symbol created for the derived type to the current ns. */
dt_list_ptr = &(gfc_derived_types);
C address of. */
tmp_sym->ts.type = BT_DERIVED;
if (s == ISOCBINDING_LOC)
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_PTR);
else
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.derived == NULL)
+ if (tmp_sym->ts.u.derived == NULL)
{
/* Create the necessary derived type so we can continue
processing the file. */
(const char *)(s == ISOCBINDING_FUNLOC
? "_gfortran_iso_c_binding_c_funptr"
: "_gfortran_iso_c_binding_c_ptr"));
- tmp_sym->ts.derived =
+ tmp_sym->ts.u.derived =
get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR);
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);
}
+/* 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 (gfc_typebound_proc *tb0)
+{
+ gfc_typebound_proc *result;
+ tentative_tbp *list_node;
+
+ result = XCNEW (gfc_typebound_proc);
+ if (tb0)
+ *result = *tb0;
+ result->error = 1;
+
+ list_node = XCNEW (tentative_tbp);
+ 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.derived;
+ return derived->components->ts.u.derived;
}
-/* Find a type-bound procedure by name for a derived-type (looking recursively
- through the super-types). */
+/* Get the ultimate super-type of a given derived type. */
-gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess)
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
{
- gfc_symtree* res;
+ if (!derived->attr.extension)
+ return NULL;
- /* Set default to failure. */
- if (t)
- *t = FAILURE;
+ derived = gfc_get_derived_super_type (derived);
- /* Try to find it in the current type's namespace. */
- gcc_assert (derived->f2k_derived);
- res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
- if (res && res->typebound)
- {
- /* We found one. */
- if (t)
- *t = SUCCESS;
+ if (derived->attr.extension)
+ return gfc_get_ultimate_derived_super_type (derived);
+ else
+ return derived;
+}
- if (!noaccess && derived->attr.use_assoc
- && res->typebound->access == ACCESS_PRIVATE)
- {
- gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
- if (t)
- *t = FAILURE;
- }
- return res;
- }
+/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
- /* Otherwise, recurse on parent type if derived is an extension. */
- if (derived->attr.extension)
- {
- 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);
- }
+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);
+}
- /* Nothing found. */
- return NULL;
+
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+ If ts1 is nonpolymorphic, ts2 must be the same type.
+ If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+ bool is_class1 = (ts1->type == BT_CLASS);
+ bool is_class2 = (ts2->type == BT_CLASS);
+ bool is_derived1 = (ts1->type == BT_DERIVED);
+ bool is_derived2 = (ts2->type == BT_DERIVED);
+
+ if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+ return (ts1->type == ts2->type);
+
+ if (is_derived1 && is_derived2)
+ return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+ if (is_class1 && is_derived2)
+ return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ ts2->u.derived);
+ else if (is_class1 && is_class2)
+ return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ ts2->u.derived->components->ts.u.derived);
+ else
+ return 0;
}
OSDN Git Service
