/* Maintain binary trees of symbols.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2013 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "flags.h"
#include "gfortran.h"
#include "parse.h"
gfc_gsymbol *gfc_gsym_root = NULL;
-static 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;
+static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
+static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
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 (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
{
/* BIND(C) variables should not be implicitly declared. */
gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
if (sym->ns->proc_name != NULL
&& (sym->ns->proc_name->attr.subroutine != 0
|| sym->ns->proc_name->attr.function != 0)
- && sym->ns->proc_name->attr.is_bind_c != 0)
+ && sym->ns->proc_name->attr.is_bind_c != 0
+ && gfc_option.warn_c_binding_type)
{
/* Dummy args to a BIND(C) routine may not be interoperable if
they are implicitly typed. */
conf (external, subroutine);
if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: Procedure pointer at %C") == FAILURE)
+ "Procedure pointer at %C") == FAILURE)
return FAILURE;
conf (allocatable, pointer);
conflict_std:
if (name == NULL)
{
- return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+ return gfc_notify_std (standard, "%s attribute "
"with %s attribute at %L", a1, a2,
where);
}
else
{
- return gfc_notify_std (standard, "Fortran 2003: %s attribute "
+ return gfc_notify_std (standard, "%s attribute "
"with %s attribute in '%s' at %L",
a1, a2, name, where);
}
if (where == NULL)
where = &gfc_current_locus;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
+ if (gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)
== FAILURE)
return FAILURE;
else
attr->extension = 1;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
+ if (gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)
== FAILURE)
return FAILURE;
if (!sym)
return NULL;
+ if (sym->attr.unlimited_polymorphic)
+ return sym;
+
if (sym->attr.generic)
sym = gfc_find_dt_in_generic (sym);
gfc_free_array_spec (p->as);
gfc_free_expr (p->initializer);
-
- gfc_free_formal_arglist (p->formal);
- gfc_free_namespace (p->formal_ns);
+ free (p->tb);
free (p);
}
switch (type)
{
case ST_LABEL_FORMAT:
- if (lp->referenced == ST_LABEL_TARGET)
+ if (lp->referenced == ST_LABEL_TARGET
+ || lp->referenced == ST_LABEL_DO_TARGET)
gfc_error ("Label %d at %C already referenced as branch target",
labelno);
else
break;
case ST_LABEL_TARGET:
+ case ST_LABEL_DO_TARGET:
if (lp->referenced == ST_LABEL_FORMAT)
gfc_error ("Label %d at %C already referenced as a format label",
labelno);
else
- lp->defined = ST_LABEL_TARGET;
+ lp->defined = type;
+ if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
+ && gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
+ "which is not END DO or CONTINUE with label "
+ "%d at %C", labelno) == FAILURE)
+ return;
break;
default:
lp->where = gfc_current_locus;
}
- if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
+ if (label_type == ST_LABEL_FORMAT
+ && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
{
gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
rc = FAILURE;
goto done;
}
- if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
+ if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
+ || label_type == ST_LABEL_BAD_TARGET)
&& type == ST_LABEL_FORMAT)
{
gfc_error ("Label %d at %C previously used as branch target", labelno);
goto done;
}
- lp->referenced = type;
+ if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+ && gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
+ "at %C", labelno) == FAILURE)
+ return FAILURE;
+
+ if (lp->referenced != ST_LABEL_DO_TARGET)
+ lp->referenced = type;
rc = SUCCESS;
done:
undo changes made to a symbol table if the current interpretation
of a statement is found to be incorrect. Whenever a symbol is
looked up, we make a copy of it and link to it. All of these
- symbols are kept in a singly linked list so that we can commit or
+ symbols are kept in a vector so that we can commit or
undo the changes at a later time.
A symtree may point to a symbol node outside of its namespace. In
gfc_free_namelist (sym->namelist);
- gfc_free_namespace (sym->formal_ns);
+ if (sym->ns != sym->formal_ns)
+ gfc_free_namespace (sym->formal_ns);
if (!sym->attr.generic_copy)
gfc_free_interface (sym->generic);
gfc_free_namespace (sym->f2k_derived);
+ if (sym->common_block && sym->common_block->name[0] != '\0')
+ {
+ sym->common_block->refs--;
+ if (sym->common_block->refs == 0)
+ free (sym->common_block);
+ }
+
free (sym);
}
if (sym == NULL)
return;
- if (sym->formal_ns != NULL && sym->refs == 2)
+ if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
+ && (!sym->attr.entry || !sym->module))
{
/* As formal_ns contains a reference to sym, delete formal_ns just
before the deletion of sym. */
}
+/* Tells whether there is only one set of changes in the stack. */
+
+static bool
+single_undo_checkpoint_p (void)
+{
+ if (latest_undo_chgset == &default_undo_chgset_var)
+ {
+ gcc_assert (latest_undo_chgset->previous == NULL);
+ return true;
+ }
+ else
+ {
+ gcc_assert (latest_undo_chgset->previous != NULL);
+ return false;
+ }
+}
+
/* Save symbol with the information necessary to back it out. */
static void
save_symbol_data (gfc_symbol *sym)
{
+ gfc_symbol *s;
+ unsigned i;
- if (sym->gfc_new || sym->old_symbol != NULL)
+ if (!single_undo_checkpoint_p ())
+ {
+ /* If there is more than one change set, look for the symbol in the
+ current one. If it is found there, we can reuse it. */
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+ if (s == sym)
+ {
+ gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
+ return;
+ }
+ }
+ else if (sym->gfc_new || sym->old_symbol != NULL)
return;
- sym->old_symbol = XCNEW (gfc_symbol);
- *(sym->old_symbol) = *sym;
+ s = XCNEW (gfc_symbol);
+ *s = *sym;
+ sym->old_symbol = s;
+ sym->gfc_new = 0;
- sym->tlink = changed_syms;
- changed_syms = sym;
+ latest_undo_chgset->syms.safe_push (sym);
}
/* Add to the list of tentative symbols. */
p->old_symbol = NULL;
- p->tlink = changed_syms;
p->mark = 1;
p->gfc_new = 1;
- changed_syms = p;
+ latest_undo_chgset->syms.safe_push (p);
st = gfc_new_symtree (&ns->sym_root, name);
st->n.sym = p;
return i;
}
-/* Undoes all the changes made to symbols in the current statement.
+
+/* Search for the symtree belonging to a gfc_common_head; we cannot use
+ head->name as the common_root symtree's name might be mangled. */
+
+static gfc_symtree *
+find_common_symtree (gfc_symtree *st, gfc_common_head *head)
+{
+
+ gfc_symtree *result;
+
+ if (st == NULL)
+ return NULL;
+
+ if (st->n.common == head)
+ return st;
+
+ result = find_common_symtree (st->left, head);
+ if (!result)
+ result = find_common_symtree (st->right, head);
+
+ return result;
+}
+
+
+/* Clear the given storage, and make it the current change set for registering
+ changed symbols. Its contents are freed after a call to
+ gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
+ it is up to the caller to free the storage itself. It is usually a local
+ variable, so there is nothing to do anyway. */
+
+void
+gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
+{
+ chg_syms.syms = vNULL;
+ chg_syms.tbps = vNULL;
+ chg_syms.previous = latest_undo_chgset;
+ latest_undo_chgset = &chg_syms;
+}
+
+
+/* Restore previous state of symbol. Just copy simple stuff. */
+
+static void
+restore_old_symbol (gfc_symbol *p)
+{
+ gfc_symbol *old;
+
+ p->mark = 0;
+ old = p->old_symbol;
+
+ p->ts.type = old->ts.type;
+ p->ts.kind = old->ts.kind;
+
+ p->attr = old->attr;
+
+ if (p->value != old->value)
+ {
+ gcc_checking_assert (old->value == NULL);
+ gfc_free_expr (p->value);
+ p->value = NULL;
+ }
+
+ if (p->as != old->as)
+ {
+ if (p->as)
+ gfc_free_array_spec (p->as);
+ p->as = old->as;
+ }
+
+ p->generic = old->generic;
+ p->component_access = old->component_access;
+
+ if (p->namelist != NULL && old->namelist == NULL)
+ {
+ gfc_free_namelist (p->namelist);
+ p->namelist = NULL;
+ }
+ else
+ {
+ if (p->namelist_tail != old->namelist_tail)
+ {
+ gfc_free_namelist (old->namelist_tail->next);
+ old->namelist_tail->next = NULL;
+ }
+ }
+
+ p->namelist_tail = old->namelist_tail;
+
+ if (p->formal != old->formal)
+ {
+ gfc_free_formal_arglist (p->formal);
+ p->formal = old->formal;
+ }
+
+ p->old_symbol = old->old_symbol;
+ free (old);
+}
+
+
+/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
+ the structure itself. */
+
+static void
+free_undo_change_set_data (gfc_undo_change_set &cs)
+{
+ cs.syms.release ();
+ cs.tbps.release ();
+}
+
+
+/* Given a change set pointer, free its target's contents and update it with
+ the address of the previous change set. Note that only the contents are
+ freed, not the target itself (the contents' container). It is not a problem
+ as the latter will be a local variable usually. */
+
+static void
+pop_undo_change_set (gfc_undo_change_set *&cs)
+{
+ free_undo_change_set_data (*cs);
+ cs = cs->previous;
+}
+
+
+static void free_old_symbol (gfc_symbol *sym);
+
+
+/* Merges the current change set into the previous one. The changes themselves
+ are left untouched; only one checkpoint is forgotten. */
+
+void
+gfc_drop_last_undo_checkpoint (void)
+{
+ gfc_symbol *s, *t;
+ unsigned i, j;
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+ {
+ /* No need to loop in this case. */
+ if (s->old_symbol == NULL)
+ continue;
+
+ /* Remove the duplicate symbols. */
+ FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
+ if (t == s)
+ {
+ latest_undo_chgset->previous->syms.unordered_remove (j);
+
+ /* S->OLD_SYMBOL is the backup symbol for S as it was at the
+ last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
+ shall contain from now on the backup symbol for S as it was
+ at the checkpoint before. */
+ if (s->old_symbol->gfc_new)
+ {
+ gcc_assert (s->old_symbol->old_symbol == NULL);
+ s->gfc_new = s->old_symbol->gfc_new;
+ free_old_symbol (s);
+ }
+ else
+ restore_old_symbol (s->old_symbol);
+ break;
+ }
+ }
+
+ latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
+ latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
+
+ pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* Undoes all the changes made to symbols since the previous checkpoint.
This subroutine is made simpler due to the fact that attributes are
never removed once added. */
void
-gfc_undo_symbols (void)
+gfc_restore_last_undo_checkpoint (void)
{
- gfc_symbol *p, *q, *old;
- tentative_tbp *tbp, *tbq;
+ gfc_symbol *p;
+ unsigned i;
- for (p = changed_syms; p; p = q)
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
{
- q = p->tlink;
-
if (p->gfc_new)
{
/* Symbol was new. */
needs to be removed to stop the resolver looking
for a (possibly) dead symbol. */
+ if (p->common_block->head == p && !p->common_next)
+ {
+ gfc_symtree st, *st0;
+ st0 = find_common_symtree (p->ns->common_root,
+ p->common_block);
+ if (st0)
+ {
+ st.name = st0->name;
+ gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
+ free (st0);
+ }
+ }
+
if (p->common_block->head == p)
p->common_block->head = p->common_next;
else
gfc_delete_symtree (&p->ns->sym_root, p->name);
gfc_release_symbol (p);
- continue;
- }
-
- /* Restore previous state of symbol. Just copy simple stuff. */
- p->mark = 0;
- old = p->old_symbol;
-
- p->ts.type = old->ts.type;
- p->ts.kind = old->ts.kind;
-
- p->attr = old->attr;
-
- if (p->value != old->value)
- {
- gfc_free_expr (old->value);
- p->value = NULL;
}
+ else
+ restore_old_symbol (p);
+ }
- if (p->as != old->as)
- {
- if (p->as)
- gfc_free_array_spec (p->as);
- p->as = old->as;
- }
+ latest_undo_chgset->syms.truncate (0);
+ latest_undo_chgset->tbps.truncate (0);
- p->generic = old->generic;
- p->component_access = old->component_access;
+ if (!single_undo_checkpoint_p ())
+ pop_undo_change_set (latest_undo_chgset);
+}
- if (p->namelist != NULL && old->namelist == NULL)
- {
- gfc_free_namelist (p->namelist);
- p->namelist = NULL;
- }
- else
- {
- if (p->namelist_tail != old->namelist_tail)
- {
- gfc_free_namelist (old->namelist_tail);
- old->namelist_tail->next = NULL;
- }
- }
- p->namelist_tail = old->namelist_tail;
+/* Makes sure that there is only one set of changes; in other words we haven't
+ forgotten to pair a call to gfc_new_checkpoint with a call to either
+ gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
- if (p->formal != old->formal)
- {
- gfc_free_formal_arglist (p->formal);
- p->formal = old->formal;
- }
+static void
+enforce_single_undo_checkpoint (void)
+{
+ gcc_checking_assert (single_undo_checkpoint_p ());
+}
- free (p->old_symbol);
- p->old_symbol = NULL;
- p->tlink = NULL;
- }
- changed_syms = NULL;
+/* Undoes all the changes made to symbols in the current statement. */
- for (tbp = tentative_tbp_list; tbp; tbp = tbq)
- {
- tbq = tbp->next;
- /* Procedure is already marked `error' by default. */
- free (tbp);
- }
- tentative_tbp_list = NULL;
+void
+gfc_undo_symbols (void)
+{
+ enforce_single_undo_checkpoint ();
+ gfc_restore_last_undo_checkpoint ();
}
void
gfc_commit_symbols (void)
{
- gfc_symbol *p, *q;
- tentative_tbp *tbp, *tbq;
+ gfc_symbol *p;
+ gfc_typebound_proc *tbp;
+ unsigned i;
+
+ enforce_single_undo_checkpoint ();
- for (p = changed_syms; p; p = q)
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
{
- q = p->tlink;
- p->tlink = NULL;
p->mark = 0;
p->gfc_new = 0;
free_old_symbol (p);
}
- changed_syms = NULL;
+ latest_undo_chgset->syms.truncate (0);
- for (tbp = tentative_tbp_list; tbp; tbp = tbq)
- {
- tbq = tbp->next;
- tbp->proc->error = 0;
- free (tbp);
- }
- tentative_tbp_list = NULL;
+ FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
+ tbp->error = 0;
+ latest_undo_chgset->tbps.truncate (0);
}
gfc_commit_symbol (gfc_symbol *sym)
{
gfc_symbol *p;
+ unsigned i;
- if (changed_syms == sym)
- changed_syms = sym->tlink;
- else
- {
- for (p = changed_syms; p; p = p->tlink)
- if (p->tlink == sym)
- {
- p->tlink = sym->tlink;
- break;
- }
- }
+ enforce_single_undo_checkpoint ();
+
+ FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+ if (p == sym)
+ {
+ latest_undo_chgset->syms.unordered_remove (i);
+ break;
+ }
- sym->tlink = NULL;
sym->mark = 0;
sym->gfc_new = 0;
void
gfc_symbol_done_2 (void)
{
-
gfc_free_namespace (gfc_current_ns);
gfc_current_ns = NULL;
gfc_free_dt_list ();
+
+ enforce_single_undo_checkpoint ();
+ free_undo_change_set_data (*latest_undo_chgset);
}
void
gfc_enforce_clean_symbol_state(void)
{
- gcc_assert (changed_syms == NULL);
+ enforce_single_undo_checkpoint ();
+ gcc_assert (latest_undo_chgset->syms.is_empty ());
}
recompiles with different flags (e.g., -m32 and -m64 on
x86_64 and using integer(4) to claim interop with a
C_LONG). */
- if (derived_sym->attr.is_bind_c == 1)
+ if (derived_sym->attr.is_bind_c == 1
+ && gfc_option.warn_c_binding_type)
/* If the derived type is bind(c), all fields must be
interop. */
gfc_warning ("Component '%s' in derived type '%s' at %L "
"derived type '%s' is BIND(C)",
curr_comp->name, derived_sym->name,
&(curr_comp->loc), derived_sym->name);
- else
+ else if (gfc_option.warn_c_binding_type)
/* If derived type is param to bind(c) routine, or to one
of the iso_c_binding procs, it must be interoperable, so
all fields must interop too. */
reference to the list of formal arguments). */
static void
-add_proc_interface (gfc_symbol *sym, ifsrc source,
- gfc_formal_arglist *formal)
+add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
{
sym->formal = formal;
args based on the args of a given named interface. */
void
-gfc_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);
- 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);
-
- /* Validate changes. */
- gfc_commit_symbol (formal_arg->sym);
- }
-
- /* Add the interface to the symbol. */
- add_proc_interface (dest, IFSRC_DECL, head);
-
- /* Store the formal namespace information. */
- if (dest->formal != NULL)
- /* The current ns should be that for the dest proc. */
- dest->formal_ns = gfc_current_ns;
- /* Restore the current namespace to what it was on entry. */
- gfc_current_ns = parent_ns;
-}
-
-
-void
gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
{
gfc_formal_arglist *head = NULL;
}
-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);
-
- /* Validate changes. */
- gfc_commit_symbol (formal_arg->sym);
- }
-
- /* Add the interface to the symbol. */
- gfc_free_formal_arglist (dest->formal);
- 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
}
if (gfc_notify_std (GFC_STD_GNU,
- "Extension: Symbol '%s' is used before"
+ "Symbol '%s' is used before"
" it is typed at %L", sym->name, &where) == FAILURE)
return FAILURE;
}
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;
+ latest_undo_chgset->tbps.safe_push (result);
return result;
}
gfc_symbol*
gfc_get_derived_super_type (gfc_symbol* derived)
{
- if (derived && derived->attr.generic)
+ gcc_assert (derived);
+
+ if (derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
if (!derived->attr.extension)
bool is_derived1 = (ts1->type == BT_DERIVED);
bool is_derived2 = (ts2->type == BT_DERIVED);
+ if (is_class1
+ && ts1->u.derived->components
+ && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ return 1;
+
if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
return (ts1->type == ts2->type);
if (!sym->assoc)
return false;
+ if (sym->ts.type == BT_CLASS)
+ return true;
+
if (!sym->assoc->variable)
return false;
return sym;
if (sym->attr.generic)
- for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
+ for (intr = sym->generic; intr; intr = intr->next)
if (intr->sym->attr.flavor == FL_DERIVED)
break;
return intr ? intr->sym : NULL;
}
+
+
+/* Get the dummy arguments from a procedure symbol. If it has been declared
+ via a PROCEDURE statement with a named interface, ts.interface will be set
+ and the arguments need to be taken from there. */
+
+gfc_formal_arglist *
+gfc_sym_get_dummy_args (gfc_symbol *sym)
+{
+ gfc_formal_arglist *dummies;
+
+ dummies = sym->formal;
+ if (dummies == NULL && sym->ts.interface != NULL)
+ dummies = sym->ts.interface->formal;
+
+ return dummies;
+}
projects / platform / upstream / gcc48.git / blobdiff