/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
/* 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;
letter = sym->name[0];
if (gfc_option.flag_allow_leading_underscore && letter == '_')
- gfc_internal_error ("Option -fallow_leading_underscore is for use only by "
+ gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
"gfortran developers, and should not be used for "
"implicitly typed variables");
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;
{
/* 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,
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",
- *is_bind_c = "BIND(C)";
+ *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
+ *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
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;
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
- case FL_PROCEDURE:
case FL_DERIVED:
case FL_PARAMETER:
a1 = gfc_code2string (flavors, attr->flavor);
a2 = save;
goto conflict;
+ case FL_PROCEDURE:
+ /* Conflicts between SAVE and PROCEDURE will be checked at
+ resolution stage, see "resolve_fl_procedure". */
case FL_VARIABLE:
case FL_NAMELIST:
default:
conf (target, external);
conf (target, intrinsic);
- conf (external, dimension); /* See Fortran 95's R504. */
+
+ if (!attr->if_source)
+ conf (external, dimension); /* See Fortran 95's R504. */
conf (external, intrinsic);
+ conf (entry, intrinsic);
- if (attr->if_source || attr->contained)
+ if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
{
conf (external, subroutine);
conf (external, function);
conf (is_bind_c, cray_pointer);
conf (is_bind_c, cray_pointee);
conf (is_bind_c, allocatable);
+ conf (is_bind_c, elemental);
/* Need to also get volatile attr, according to 5.1 of F2003 draft.
Parameter conflict caught below. Also, value cannot be specified
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)
goto conflict;
}
+ conf (procedure, allocatable)
+ conf (procedure, dimension)
+ conf (procedure, intrinsic)
+ conf (procedure, is_protected)
+ conf (procedure, target)
+ conf (procedure, value)
+ conf (procedure, volatile_)
+ conf (procedure, entry)
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
conf2 (dummy);
conf2 (volatile_);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+
+ if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
+ {
+ a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
+ gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
+ name, where);
+ return FAILURE;
+ }
+
+ if (attr->is_bind_c)
+ {
+ gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
+ return FAILURE;
+ }
+
break;
case FL_VARIABLE:
break;
case FL_PROCEDURE:
- conf2 (intent);
+ /* Conflicts with INTENT will be checked at resolution stage,
+ see "resolve_fl_procedure". */
if (attr->subroutine)
{
- conf2 (pointer);
conf2 (target);
conf2 (allocatable);
conf2 (result);
conf2 (subroutine);
conf2 (entry);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
- /* TODO: hmm, double check this. */
conf2 (value);
+ conf2 (is_bind_c);
break;
default:
/* Called from decl.c (attr_decl1) to check attributes, when declared
separately. */
-try
+gfc_try
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
return FAILURE;
}
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ {
+ gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
+ where);
+ return FAILURE;
+ }
+
attr->allocatable = 1;
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
return FAILURE;
}
+ if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE)
+ {
+ gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
+ "at %L", name, where);
+ return FAILURE;
+ }
+
attr->dimension = 1;
return check_conflict (attr, name, where);
}
-try
+gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
return FAILURE;
}
+ if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->external = 1;
return check_conflict (attr, NULL, 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)
{
if (check_used (attr, NULL, where))
return FAILURE;
- attr->pointer = 1;
+ if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ {
+ duplicate_attr ("POINTER", where);
+ return FAILURE;
+ }
+
+ if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+ || (attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
return check_conflict (attr, NULL, 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)
{
}
-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)
{
}
-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)
{
if (check_used (attr, NULL, where))
return FAILURE;
+ if (attr->elemental)
+ {
+ duplicate_attr ("ELEMENTAL", where);
+ return FAILURE;
+ }
+
attr->elemental = 1;
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_pure (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return FAILURE;
+ if (attr->pure)
+ {
+ duplicate_attr ("PURE", where);
+ return FAILURE;
+ }
+
attr->pure = 1;
return check_conflict (attr, NULL, where);
}
-try
+gfc_try
gfc_add_recursive (symbol_attribute *attr, locus *where)
{
if (check_used (attr, NULL, where))
return FAILURE;
+ if (attr->recursive)
+ {
+ duplicate_attr ("RECURSIVE", where);
+ return FAILURE;
+ }
+
attr->recursive = 1;
return check_conflict (attr, NULL, 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)
{
}
+gfc_try
+gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return FAILURE;
+
+ if (attr->flavor != FL_PROCEDURE
+ && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
+ return FAILURE;
+
+ if (attr->procedure)
+ {
+ duplicate_attr ("PROCEDURE", where);
+ return FAILURE;
+ }
+
+ attr->procedure = 1;
+
+ return check_conflict (attr, NULL, where);
+}
+
+
/* 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)
{
/* 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)
{
return FAILURE;
}
+ if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
+ {
+ gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
+ "body", sym->name, where);
+ return FAILURE;
+ }
+
sym->formal = formal;
sym->attr.if_source = source;
/* Add a type to a symbol. */
-try
+gfc_try
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor 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;
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;
goto fail;
if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
goto fail;
+ if (src->proc_pointer)
+ dest->proc_pointer = 1;
return SUCCESS;
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))
+ {
+ 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 ();
gfc_symtree *st;
int i;
- if (sym->components != NULL)
+ if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
if (sym->ns->parent == NULL)
if (strcmp (p->name, name) == 0)
break;
+ if (p == NULL
+ && sym->attr.extension
+ && sym->components->ts.type == BT_DERIVED)
+ {
+ p = gfc_find_component (sym->components->ts.derived, name);
+ /* Do not overwrite the error. */
+ if (p == NULL)
+ return p;
+ }
+
if (p == NULL)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else
+
+ else if (sym->attr.use_assoc)
{
- if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
- || p->access == ACCESS_PRIVATE))
+ if (p->access == ACCESS_PRIVATE)
{
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
- p = NULL;
+ return NULL;
+ }
+
+ /* If there were components given and all components are private, error
+ out at this place. */
+ if (p->access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
+ {
+ gfc_error ("All components of '%s' are PRIVATE in structure"
+ " constructor at %C", sym->name);
+ return NULL;
}
}
lp = lp->right;
}
- lp = gfc_getmem (sizeof (gfc_st_label));
+ lp = XCNEW (gfc_st_label);
lp->value = labelno;
lp->defined = ST_LABEL_UNKNOWN;
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_intrinsic_op in;
int i;
- ns = gfc_getmem (sizeof (gfc_namespace));
+ ns = XCNEW (gfc_namespace);
ns->sym_root = NULL;
ns->uop_root = NULL;
+ ns->finalizers = NULL;
ns->default_access = ACCESS_UNKNOWN;
ns->parent = parent;
{
gfc_symtree *st;
- st = gfc_getmem (sizeof (gfc_symtree));
+ st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
gfc_insert_bbt (root, st, compare_symtree);
/* Delete a symbol from the tree. Does not free the symbol itself! */
-static void
-delete_symtree (gfc_symtree **root, const char *name)
+void
+gfc_delete_symtree (gfc_symtree **root, const char *name)
{
gfc_symtree st, *st0;
st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
- uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
+ uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
uop->ns = gfc_current_ns;
gfc_free_formal_arglist (sym->formal);
+ gfc_free_namespace (sym->f2k_derived);
+
gfc_free (sym);
}
{
gfc_symbol *p;
- p = gfc_getmem (sizeof (gfc_symbol));
+ p = XCNEW (gfc_symbol);
gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
/* Clear the ptrs we may need. */
p->common_block = NULL;
+ p->f2k_derived = NULL;
return p;
}
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 = gfc_getmem (sizeof (gfc_symbol));
+ sym->old_symbol = XCNEW (gfc_symbol);
*(sym->old_symbol) = *sym;
sym->tlink = changed_syms;
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))
+ 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)))
{
/* Symbol is from another namespace. */
gfc_error ("Symbol '%s' at %C has already been host associated",
{
q = p->tlink;
- if (p->new)
+ if (p->gfc_new)
{
/* Symbol was new. */
- delete_symtree (&p->ns->sym_root, p->name);
+ if (p->attr.in_common && p->common_block->head)
+ {
+ /* If the symbol was added to any common block, it
+ needs to be removed to stop the resolver looking
+ for a (possibly) dead symbol. */
+
+ if (p->common_block->head == p)
+ p->common_block->head = p->common_next;
+ else
+ {
+ gfc_symbol *cparent, *csym;
+
+ cparent = p->common_block->head;
+ csym = cparent->common_next;
+
+ while (csym != p)
+ {
+ cparent = csym;
+ csym = csym->common_next;
+ }
+
+ gcc_assert(cparent->common_next == p);
+
+ cparent->common_next = csym->common_next;
+ }
+ }
+
+ gfc_delete_symtree (&p->ns->sym_root, p->name);
p->refs--;
if (p->refs < 0)
q = p->tlink;
p->tlink = NULL;
p->mark = 0;
- p->new = 0;
+ p->gfc_new = 0;
free_old_symbol (p);
}
changed_syms = NULL;
sym->tlink = NULL;
sym->mark = 0;
- sym->new = 0;
+ sym->gfc_new = 0;
free_old_symbol (sym);
}
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 a finalizer procedure list. */
+
+void
+gfc_free_finalizer (gfc_finalizer* el)
+{
+ if (el)
+ {
+ if (el->proc_sym)
+ {
+ --el->proc_sym->refs;
+ if (!el->proc_sym->refs)
+ gfc_free_symbol (el->proc_sym);
+ }
+
+ gfc_free (el);
+ }
+}
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* list)
+{
+ while (list)
+ {
+ gfc_finalizer* current = list;
+ list = list->next;
+ gfc_free_finalizer (current);
+ }
+}
+
+
/* 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. */
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ gfc_free_finalizer_list (ns->finalizers);
for (cl = ns->cl_list; cl; cl = cl2)
{
gfc_free_equiv_lists (ns->equiv_lists);
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;
void
gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
{
- if (st != NULL)
- {
- (*func) (st);
+ if (!st)
+ return;
- gfc_traverse_symtree (st->left, func);
- gfc_traverse_symtree (st->right, func);
- }
+ gfc_traverse_symtree (st->left, func);
+ (*func) (st);
+ gfc_traverse_symtree (st->right, func);
}
if (st == NULL)
return;
+ traverse_ns (st->left, func);
+
if (st->n.sym->mark == 0)
(*func) (st->n.sym);
st->n.sym->mark = 1;
- traverse_ns (st->left, func);
traverse_ns (st->right, func);
}
}
+/* Return TRUE when name is the name of an intrinsic type. */
+
+bool
+gfc_is_intrinsic_typename (const char *name)
+{
+ if (strcmp (name, "integer") == 0
+ || strcmp (name, "real") == 0
+ || strcmp (name, "character") == 0
+ || strcmp (name, "logical") == 0
+ || strcmp (name, "complex") == 0
+ || strcmp (name, "doubleprecision") == 0
+ || strcmp (name, "doublecomplex") == 0)
+ return true;
+ else
+ return false;
+}
+
+
/* Return TRUE if the symbol is an automatic variable. */
static bool
if (s != NULL)
return s;
- s = gfc_getmem (sizeof (gfc_gsymbol));
+ s = XCNEW (gfc_gsymbol);
s->type = GSYM_UNKNOWN;
s->name = gfc_get_string (name);
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 "
/* 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)
{
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 ();
- /* This line will initialize the c_null_ptr/c_null_funptr
- c_address field to NULL. */
- tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
/* 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;
gen_fptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
- gfc_namespace *ns, const char *f_ptr_name)
+ gfc_namespace *ns, const char *f_ptr_name, int proc)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
/* Set up the necessary fields for the fptr output param sym. */
param_sym->refs++;
- param_sym->attr.pointer = 1;
+ if (proc)
+ param_sym->attr.proc_pointer = 1;
+ else
+ param_sym->attr.pointer = 1;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
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
+ used when creating procedure declaration variables from a procedure
+ declaration statement (see match_proc_decl()) to create the formal
+ args based on the args of a given named interface. */
+
+void
+copy_formal_args (gfc_symbol *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);
+ 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);
+
+ /* 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;
+}
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
gfc_current_ns->proc_name = new_proc_sym;
/* Generate the params. */
- if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
- (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr");
-
+ gfc_current_ns, "fptr", 1);
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 0);
/* If we're dealing with c_f_pointer, it has an optional third arg. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_shape_param (&head, &tail,
- (const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
- }
+ gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+
}
else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
gfc_current_ns = parent_ns;
}
+static int
+std_for_isocbinding_symbol (int id)
+{
+ switch (id)
+ {
+#define NAMED_INTCST(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+ default:
+ return GFC_STD_F2003;
+ }
+}
/* Generate the given set of C interoperable kind objects, or all
interoperable kinds. This function will only be given kind objects
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
+ if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE)
+ return;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Already exists in this scope so don't re-add it.
switch (s)
{
-#define NAMED_INTCST(a,b,c) case a :
+#define NAMED_INTCST(a,b,c,d) case a :
#define NAMED_REALCST(a,b,c) case a :
#define NAMED_CMPXCST(a,b,c) case a :
#define NAMED_LOGCST(a,b,c) case a :
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_getmem (2);
+ tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
- = (char) c_interop_kinds_table[s].value;
+ = (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);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
new_symtree->n.sym->attr = old_sym->attr;
new_symtree->n.sym->ts = old_sym->ts;
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;
/* Build the formal arg list. */
build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
OSDN Git Service
