/* 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->cl)
+ {
+ sym->ts.cl = gfc_get_charlen ();
+ *sym->ts.cl = *ts->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",
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);
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 (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))
}
-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)
{
}
-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;
+ dest->ext_attr = src->ext_attr;
+
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
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.derived, name, true, true))
+ {
+ gfc_error ("Component '%s' at %C already in the parent type "
+ "at %L", name, &sym->components->ts.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;
/* 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.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
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++)
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;
}
}
- 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)
{
}
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;
{
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. */
+
+gfc_charlen*
+gfc_new_charlen (gfc_namespace *ns)
+{
+ gfc_charlen *cl;
+ cl = gfc_get_charlen ();
+ cl->next = ns->cl_list;
+ ns->cl_list = cl;
+ return cl;
+}
+
+
+/* Free the charlen list from cl to end (end is not freed).
+ Free the whole list if end is NULL. */
+
+void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
+{
+ gfc_charlen *cl2;
+
+ for (; cl != end; cl = cl2)
+ {
+ gcc_assert (cl);
+
+ cl2 = cl->next;
+ gfc_free_expr (cl->length);
+ gfc_free (cl);
+ }
+}
+
+
/* Free a namespace structure and everything below it. Interface
lists associated with intrinsic operators are not freed. These are
taken care of when a specific name is freed. */
void
gfc_free_namespace (gfc_namespace *ns)
{
- gfc_charlen *cl, *cl2;
gfc_namespace *p, *q;
- gfc_intrinsic_op i;
+ int i;
if (ns == NULL)
return;
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ free_tb_tree (ns->tb_sym_root);
+ free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
-
- for (cl = ns->cl_list; cl; cl = cl2)
- {
- cl2 = cl->next;
- gfc_free_expr (cl->length);
- gfc_free (cl);
- }
-
+ gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
gfc_free_equiv (ns->equiv);
gfc_free_equiv_lists (ns->equiv_lists);
+ gfc_free_use_stmts (ns->use_stmts);
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
gfc_free_interface (ns->op[i]);
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 "
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)
{
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
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
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.cl = gfc_new_charlen (gfc_current_ns);
+
+ /* 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_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
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;
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.derived);
+
+ return derived->components->ts.derived;
+}
+
+
+/* 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)
+{
+ 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)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->n.tb->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+ 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);
+ }
+
+ /* 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)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, false);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, true);
+}
+
+
+/* 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)
+{
+ 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)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' of '%s' is PRIVATE at %C",
+ gfc_op2string (op), derived->name);
+ 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);
+ }
+
+ /* 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
