/* Perform type resolution on the various structures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
/* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
type, lists the only ways a character length value of * can be used:
dummy arguments of procedures, named constants, and function results
- in external functions. Internal function results are not on that list;
- ergo, not permitted. */
+ in external functions. Internal function results and results of module
+ procedures are not on this list, ergo, not permitted. */
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
if (!cl || !cl->length)
- gfc_error ("Character-valued internal function '%s' at %L must "
- "not be assumed length", sym->name, &sym->declared_at);
+ {
+ /* See if this is a module-procedure and adapt error message
+ accordingly. */
+ bool module_proc;
+ gcc_assert (ns->parent && ns->parent->proc_name);
+ module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
+
+ gfc_error ("Character-valued %s '%s' at %L must not be"
+ " assumed length",
+ module_proc ? _("module procedure")
+ : _("internal function"),
+ sym->name, &sym->declared_at);
+ }
}
}
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
else if (sym->attr.result
- ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+ || gfc_is_function_return_value (sym, gfc_current_ns))
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
"that is also a function result", sym->name,
&common_root->n.common->where);
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
- && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL)
+ && expr->ts.u.derived->ts.is_iso_c && cons
+ && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
{
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
expr->ts.u.derived->name, &(expr->where));
return FAILURE;
}
+ /* Return if structure constructor is c_null_(fun)prt. */
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->ts.is_iso_c && cons
+ && cons->expr && cons->expr->expr_type == EXPR_NULL)
+ return SUCCESS;
+
for (; comp; comp = comp->next, cons = cons->next)
{
int rank;
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
- || comp->attr.proc_pointer))
+ || comp->attr.proc_pointer
+ || (comp->ts.type == BT_CLASS
+ && (comp->ts.u.derived->components->attr.pointer
+ || comp->ts.u.derived->components->attr.allocatable))))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
"for pointer component '%s' should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
+
+ /* F2003, C1272 (3). */
+ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
+ && gfc_impure_variable (cons->expr->symtree->n.sym))
+ {
+ t = FAILURE;
+ gfc_error ("Invalid expression in the derived type constructor for pointer "
+ "component '%s' at %L in PURE procedure", comp->name,
+ &cons->expr->where);
+ }
}
return t;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target || a.volatile_
- || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
+ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
+ || a.asynchronous)
return 1;
return 0;
{
gfc_symbol* proc_sym;
gfc_symbol* context_proc;
+ gfc_namespace* real_context;
+
+ if (sym->attr.flavor == FL_PROGRAM)
+ return false;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
if (proc_sym->attr.recursive || gfc_option.flag_recursive)
return false;
- /* Find the context procdure's "real" symbol if it has entries. */
- context_proc = (context->entries ? context->entries->sym
- : context->proc_name);
- if (!context_proc)
- return true;
+ /* Find the context procedure's "real" symbol if it has entries.
+ We look for a procedure symbol, so recurse on the parents if we don't
+ find one (like in case of a BLOCK construct). */
+ for (real_context = context; ; real_context = real_context->parent)
+ {
+ /* We should find something, eventually! */
+ gcc_assert (real_context);
+
+ context_proc = (real_context->entries ? real_context->entries->sym
+ : real_context->proc_name);
+
+ /* In some special cases, there may not be a proc_name, like for this
+ invalid code:
+ real(bad_kind()) function foo () ...
+ when checking the call to bad_kind ().
+ In these cases, we simply return here and assume that the
+ call is ok. */
+ if (!context_proc)
+ return false;
+
+ if (context_proc->attr.flavor != FL_LABEL)
+ break;
+ }
/* A call from sym's body to itself is recursion, of course. */
if (context_proc == proc_sym)
if (gfc_is_proc_ptr_comp (e, &comp))
{
e->ts = comp->ts;
- if (e->value.compcall.actual == NULL)
- e->expr_type = EXPR_VARIABLE;
- else
+ if (e->expr_type == EXPR_PPC)
{
if (comp->as != NULL)
e->rank = comp->as->rank;
e->expr_type = EXPR_FUNCTION;
}
+ if (gfc_resolve_expr (e) == FAILURE)
+ return FAILURE;
goto argument_list;
}
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
- if (sym->attr.function && sym->result == sym
- && (sym->ns->proc_name == sym
- || (sym->ns->parent != NULL
- && sym->ns->parent->proc_name == sym)))
+ if (gfc_is_function_return_value (sym, sym->ns))
goto got_variable;
/* If all else fails, see if we have a specific intrinsic. */
gfc_error ("The reference to function '%s' at %L either needs an "
"explicit INTERFACE or the rank is incorrect", sym->name,
where);
+
+ /* Non-assumed length character functions. */
+ if (sym->attr.function && sym->ts.type == BT_CHARACTER
+ && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ {
+ gfc_charlen *cl = sym->ts.u.cl;
+
+ if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Nonconstant character-length function '%s' at %L "
+ "must have an explicit interface", sym->name,
+ &sym->declared_at);
+ }
+ }
if (gfc_option.flag_whole_file == 1
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
if (expr->symtree)
sym = expr->symtree->n.sym;
+ /* If this is a procedure pointer component, it has already been resolved. */
+ if (gfc_is_proc_ptr_comp (expr, NULL))
+ return SUCCESS;
+
if (sym && sym->attr.intrinsic
&& resolve_intrinsic (sym, &expr->where) == FAILURE)
return FAILURE;
return FAILURE;
}
- if (sym && sym->attr.abstract)
+ /* If this ia a deferred TBP with an abstract interface (which may
+ of course be referenced), expr->value.function.esym will be set. */
+ if (sym && sym->attr.abstract && !expr->value.function.esym)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
sym->name, &expr->where);
}
}
+ /* If this ia a deferred TBP with an abstract interface
+ (which may of course be referenced), c->expr1 will be set. */
+ if (csym && csym->attr.abstract && !c->expr1)
+ {
+ gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+ csym->name, &c->loc);
+ return FAILURE;
+ }
+
/* Subroutines without the RECURSIVE attribution are not allowed to
* call themselves. */
if (csym && is_illegal_recursion (csym, gfc_current_ns))
case INTRINSIC_POWER:
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
- gfc_type_convert_binary (e);
+ gfc_type_convert_binary (e, 1);
break;
}
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
- gfc_type_convert_binary (e);
+ gfc_type_convert_binary (e, 1);
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
bad_op:
- if (gfc_extend_expr (e) == SUCCESS)
- return SUCCESS;
+ {
+ bool real_error;
+ if (gfc_extend_expr (e, &real_error) == SUCCESS)
+ return SUCCESS;
+
+ if (real_error)
+ return FAILURE;
+ }
if (dual_locus_error)
gfc_error (msg, &op1->where, &op2->where);
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
gfc_symbol *derived;
gfc_ref *ref;
- as = e->symtree->n.sym->as;
+ if (e->symtree->n.sym->ts.type == BT_CLASS)
+ as = e->symtree->n.sym->ts.u.derived->components->as;
+ else
+ as = e->symtree->n.sym->as;
derived = NULL;
for (ref = e->ref; ref; ref = ref->next)
if (derived == NULL)
derived = e->symtree->n.sym->ts.u.derived;
+ if (derived->attr.is_class)
+ derived = derived->components->ts.u.derived;
+
c = derived->components;
for (; c; c = c->next)
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
- if (ref->u.c.component->attr.pointer)
+ /* F03:C614. */
+ if (ref->u.c.component->attr.pointer
+ || ref->u.c.component->attr.proc_pointer)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
gcc_assert (e->expr_type == EXPR_COMPCALL);
- po = gfc_get_expr ();
- po->expr_type = EXPR_VARIABLE;
- po->symtree = e->symtree;
- po->ref = gfc_copy_ref (e->ref);
+ if (e->value.compcall.base_object)
+ po = gfc_copy_expr (e->value.compcall.base_object);
+ else
+ {
+ po = gfc_get_expr ();
+ po->expr_type = EXPR_VARIABLE;
+ po->symtree = e->symtree;
+ po->ref = gfc_copy_ref (e->ref);
+ po->where = e->where;
+ }
if (gfc_resolve_expr (po) == FAILURE)
return NULL;
if (!po)
return FAILURE;
- if (po->rank > 0)
- {
- gfc_error ("Passed-object at %L must be scalar", &e->where);
- return FAILURE;
- }
-
- if (tbp->nopass)
+ if (tbp->nopass || e->value.compcall.ignore_pass)
{
gfc_free_expr (po);
return SUCCESS;
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
+ po->where = e->where;
/* Remove PPC reference. */
ref = &po->ref;
while ((*ref)->next)
- (*ref) = (*ref)->next;
+ ref = &(*ref)->next;
gfc_free_ref_list (*ref);
*ref = NULL;
if (!base)
return FAILURE;
- gcc_assert (base->ts.type == BT_DERIVED);
- if (base->ts.u.derived->attr.abstract)
+ gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+
+ if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
return FAILURE;
}
+ /* If the procedure called is NOPASS, the base object must be scalar. */
+ if (e->value.compcall.tbp->nopass && base->rank > 0)
+ {
+ gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
+ " be scalar", &e->where);
+ return FAILURE;
+ }
+
+ /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
+ if (base->rank > 0)
+ {
+ gfc_error ("Non-scalar base object at %L currently not implemented",
+ &e->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
c->ext.actual = newactual;
c->symtree = target;
- c->op = EXEC_CALL;
+ c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
gfc_free_expr (c->expr1);
- c->expr1 = NULL;
+ c->expr1 = gfc_get_expr ();
+ c->expr1->expr_type = EXPR_FUNCTION;
+ c->expr1->symtree = target;
+ c->expr1->where = c->loc;
return resolve_call (c);
}
-/* Resolve a component-call expression. */
-
+/* Resolve a component-call expression. This originally was intended
+ only to see functions. However, it is convenient to use it in
+ resolving subroutine class methods, since we do not have to add a
+ gfc_code each time. */
static gfc_try
-resolve_compcall (gfc_expr* e)
+resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (!e->value.compcall.tbp->function)
+ if (fcn && !e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
+ else if (!fcn && !e->value.compcall.tbp->subroutine)
+ {
+ /* To resolve class member calls, we borrow this bit
+ of code to select the specific procedures. */
+ gfc_error ("'%s' at %L should be a SUBROUTINE",
+ e->value.compcall.name, &e->where);
+ return FAILURE;
+ }
+
+ /* These must not be assign-calls! */
+ gcc_assert (!e->value.compcall.assign);
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
return FAILURE;
e->value.function.actual = newactual;
- e->value.function.name = e->value.compcall.name;
+ e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
+ e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
- return gfc_resolve_expr (e);
+ /* Resolution is not necessary when constructing component calls
+ for class members, since this must only be done for the
+ declared type, which is done afterwards. */
+ return !class_members ? gfc_resolve_expr (e) : SUCCESS;
+}
+
+
+/* Resolve a typebound call for the members in a class. This group of
+ functions implements dynamic dispatch in the provisional version
+ of f03 OOP. As soon as vtables are in place and contain pointers
+ to methods, this will no longer be necessary. */
+static gfc_expr *list_e;
+static void check_class_members (gfc_symbol *);
+static gfc_try class_try;
+static bool fcn_flag;
+
+
+static void
+check_members (gfc_symbol *derived)
+{
+ if (derived->attr.flavor == FL_DERIVED)
+ check_class_members (derived);
+}
+
+
+static void
+check_class_members (gfc_symbol *derived)
+{
+ gfc_expr *e;
+ gfc_symtree *tbp;
+ gfc_class_esym_list *etmp;
+
+ e = gfc_copy_expr (list_e);
+
+ tbp = gfc_find_typebound_proc (derived, &class_try,
+ e->value.compcall.name,
+ false, &e->where);
+
+ if (tbp == NULL)
+ {
+ gfc_error ("no typebound available procedure named '%s' at %L",
+ e->value.compcall.name, &e->where);
+ return;
+ }
+
+ /* If we have to match a passed class member, force the actual
+ expression to have the correct type. */
+ if (!tbp->n.tb->nopass)
+ {
+ if (e->value.compcall.base_object == NULL)
+ e->value.compcall.base_object = extract_compcall_passed_object (e);
+
+ if (!derived->attr.abstract)
+ {
+ e->value.compcall.base_object->ts.type = BT_DERIVED;
+ e->value.compcall.base_object->ts.u.derived = derived;
+ }
+ }
+
+ e->value.compcall.tbp = tbp->n.tb;
+ e->value.compcall.name = tbp->name;
+
+ /* Let the original expresssion catch the assertion in
+ resolve_compcall, since this flag does not appear to be reset or
+ copied in some systems. */
+ e->value.compcall.assign = 0;
+
+ /* Do the renaming, PASSing, generic => specific and other
+ good things for each class member. */
+ class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
+ ? class_try : FAILURE;
+
+ /* Now transfer the found symbol to the esym list. */
+ if (class_try == SUCCESS)
+ {
+ etmp = list_e->value.function.class_esym;
+ list_e->value.function.class_esym
+ = gfc_get_class_esym_list();
+ list_e->value.function.class_esym->next = etmp;
+ list_e->value.function.class_esym->derived = derived;
+ list_e->value.function.class_esym->esym
+ = e->value.function.esym;
+ }
+
+ gfc_free_expr (e);
+
+ /* Burrow down into grandchildren types. */
+ if (derived->f2k_derived)
+ gfc_traverse_ns (derived->f2k_derived, check_members);
+}
+
+
+/* Eliminate esym_lists where all the members point to the
+ typebound procedure of the declared type; ie. one where
+ type selection has no effect.. */
+static void
+resolve_class_esym (gfc_expr *e)
+{
+ gfc_class_esym_list *p, *q;
+ bool empty = true;
+
+ gcc_assert (e && e->expr_type == EXPR_FUNCTION);
+
+ p = e->value.function.class_esym;
+ if (p == NULL)
+ return;
+
+ for (; p; p = p->next)
+ empty = empty && (e->value.function.esym == p->esym);
+
+ if (empty)
+ {
+ p = e->value.function.class_esym;
+ for (; p; p = q)
+ {
+ q = p->next;
+ gfc_free (p);
+ }
+ e->value.function.class_esym = NULL;
+ }
+}
+
+
+/* Generate an expression for the hash value, given the reference to
+ the class of the final expression (class_ref), the base of the
+ full reference list (new_ref), the declared type and the class
+ object (st). */
+static gfc_expr*
+hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
+{
+ gfc_expr *hash_value;
+
+ /* Build an expression for the correct hash_value; ie. that of the last
+ CLASS reference. */
+ if (class_ref)
+ {
+ class_ref->next = NULL;
+ }
+ else
+ {
+ gfc_free_ref_list (new_ref);
+ new_ref = NULL;
+ }
+ hash_value = gfc_get_expr ();
+ hash_value->expr_type = EXPR_VARIABLE;
+ hash_value->symtree = st;
+ hash_value->symtree->n.sym->refs++;
+ hash_value->ref = new_ref;
+ gfc_add_component_ref (hash_value, "$vptr");
+ gfc_add_component_ref (hash_value, "$hash");
+
+ return hash_value;
+}
+
+
+/* Get the ultimate declared type from an expression. In addition,
+ return the last class/derived type reference and the copy of the
+ reference list. */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+ gfc_expr *e)
+{
+ gfc_symbol *declared;
+ gfc_ref *ref;
+
+ declared = NULL;
+ *class_ref = NULL;
+ *new_ref = gfc_copy_ref (e->ref);
+ for (ref = *new_ref; ref; ref = ref->next)
+ {
+ if (ref->type != REF_COMPONENT)
+ continue;
+
+ if (ref->u.c.component->ts.type == BT_CLASS
+ || ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ declared = ref->u.c.component->ts.u.derived;
+ *class_ref = ref;
+ }
+ }
+
+ if (declared == NULL)
+ declared = e->symtree->n.sym->ts.u.derived;
+
+ return declared;
+}
+
+
+/* Resolve the argument expressions so that any arguments expressions
+ that include class methods are resolved before the current call.
+ This is necessary because of the static variables used in CLASS
+ method resolution. */
+static void
+resolve_arg_exprs (gfc_actual_arglist *arg)
+{
+ /* Resolve the actual arglist expressions. */
+ for (; arg; arg = arg->next)
+ {
+ if (arg->expr)
+ gfc_resolve_expr (arg->expr);
+ }
+}
+
+
+/* Resolve a typebound function, or 'method'. First separate all
+ the non-CLASS references by calling resolve_compcall directly.
+ Then treat the CLASS references by resolving for each of the class
+ members in turn. */
+
+static gfc_try
+resolve_typebound_function (gfc_expr* e)
+{
+ gfc_symbol *derived, *declared;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+
+ st = e->symtree;
+ if (st == NULL)
+ return resolve_compcall (e, true, false);
+
+ /* Get the CLASS declared type. */
+ declared = get_declared_from_expr (&class_ref, &new_ref, e);
+
+ /* Weed out cases of the ultimate component being a derived type. */
+ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_compcall (e, true, false);
+ }
+
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (e->value.function.actual);
+
+ /* Get the data component, which is of the declared type. */
+ derived = declared->components->ts.u.derived;
+
+ /* Resolve the function call for each member of the class. */
+ class_try = SUCCESS;
+ fcn_flag = true;
+ list_e = gfc_copy_expr (e);
+ check_class_members (derived);
+
+ class_try = (resolve_compcall (e, true, false) == SUCCESS)
+ ? class_try : FAILURE;
+
+ /* Transfer the class list to the original expression. Note that
+ the class_esym list is cleaned up in trans-expr.c, as the calls
+ are translated. */
+ e->value.function.class_esym = list_e->value.function.class_esym;
+ list_e->value.function.class_esym = NULL;
+ gfc_free_expr (list_e);
+
+ resolve_class_esym (e);
+
+ /* More than one typebound procedure so transmit an expression for
+ the hash_value as the selector. */
+ if (e->value.function.class_esym != NULL)
+ e->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
+
+ return class_try;
+}
+
+/* Resolve a typebound subroutine, or 'method'. First separate all
+ the non-CLASS references by calling resolve_typebound_call directly.
+ Then treat the CLASS references by resolving for each of the class
+ members in turn. */
+
+static gfc_try
+resolve_typebound_subroutine (gfc_code *code)
+{
+ gfc_symbol *derived, *declared;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+
+ st = code->expr1->symtree;
+ if (st == NULL)
+ return resolve_typebound_call (code);
+
+ /* Get the CLASS declared type. */
+ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+
+ /* Weed out cases of the ultimate component being a derived type. */
+ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_typebound_call (code);
+ }
+
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (code->expr1->value.compcall.actual);
+
+ /* Get the data component, which is of the declared type. */
+ derived = declared->components->ts.u.derived;
+
+ class_try = SUCCESS;
+ fcn_flag = false;
+ list_e = gfc_copy_expr (code->expr1);
+ check_class_members (derived);
+
+ class_try = (resolve_typebound_call (code) == SUCCESS)
+ ? class_try : FAILURE;
+
+ /* Transfer the class list to the original expression. Note that
+ the class_esym list is cleaned up in trans-expr.c, as the calls
+ are translated. */
+ code->expr1->value.function.class_esym
+ = list_e->value.function.class_esym;
+ list_e->value.function.class_esym = NULL;
+ gfc_free_expr (list_e);
+
+ resolve_class_esym (code->expr1);
+
+ /* More than one typebound procedure so transmit an expression for
+ the hash_value as the selector. */
+ if (code->expr1->value.function.class_esym != NULL)
+ code->expr1->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
+
+ return class_try;
}
resolve_ppc_call (gfc_code* c)
{
gfc_component *comp;
- gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
+ bool b;
+
+ b = gfc_is_proc_ptr_comp (c->expr1, &comp);
+ gcc_assert (b);
c->resolved_sym = c->expr1->symtree->n.sym;
c->expr1->expr_type = EXPR_VARIABLE;
resolve_expr_ppc (gfc_expr* e)
{
gfc_component *comp;
- gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
+ bool b;
+
+ b = gfc_is_proc_ptr_comp (e, &comp);
+ gcc_assert (b);
/* Convert to EXPR_FUNCTION. */
e->expr_type = EXPR_FUNCTION;
}
+static bool
+gfc_is_expandable_expr (gfc_expr *e)
+{
+ gfc_constructor *con;
+
+ if (e->expr_type == EXPR_ARRAY)
+ {
+ /* Traverse the constructor looking for variables that are flavor
+ parameter. Parameters must be expanded since they are fully used at
+ compile time. */
+ for (con = e->value.constructor; con; con = con->next)
+ {
+ if (con->expr->expr_type == EXPR_VARIABLE
+ && con->expr->symtree
+ && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+ || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
+ return true;
+ if (con->expr->expr_type == EXPR_ARRAY
+ && gfc_is_expandable_expr (con->expr))
+ return true;
+ }
+ }
+
+ return false;
+}
+
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
break;
case EXPR_COMPCALL:
- t = resolve_compcall (e);
+ t = resolve_typebound_function (e);
break;
case EXPR_SUBSTRING:
if (t == SUCCESS)
{
expression_rank (e);
- gfc_expand_constructor (e);
+ if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
+ gfc_expand_constructor (e);
}
/* This provides the opportunity for the length of constructors with
character valued function elements to propagate the string length
to the expression. */
if (t == SUCCESS && e->ts.type == BT_CHARACTER)
- t = gfc_resolve_character_array_constructor (e);
+ {
+ /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
+ here rather then add a duplicate test for it above. */
+ gfc_expand_constructor (e);
+ t = gfc_resolve_character_array_constructor (e);
+ }
break;
symbol_attribute attr;
int allocatable, pointer, check_intent_in;
gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *c;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
if (e->expr_type != EXPR_VARIABLE)
goto bad;
- allocatable = e->symtree->n.sym->attr.allocatable;
- pointer = e->symtree->n.sym->attr.pointer;
+ sym = e->symtree->n.sym;
+
+ if (sym->ts.type == BT_CLASS)
+ {
+ allocatable = sym->ts.u.derived->components->attr.allocatable;
+ pointer = sym->ts.u.derived->components->attr.pointer;
+ }
+ else
+ {
+ allocatable = sym->attr.allocatable;
+ pointer = sym->attr.pointer;
+ }
for (ref = e->ref; ref; ref = ref->next)
{
if (pointer)
break;
case REF_COMPONENT:
- allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->attr.pointer;
+ c = ref->u.c.component;
+ if (c->ts.type == BT_CLASS)
+ {
+ allocatable = c->ts.u.derived->components->attr.allocatable;
+ pointer = c->ts.u.derived->components->attr.pointer;
+ }
+ else
+ {
+ allocatable = c->attr.allocatable;
+ pointer = c->attr.pointer;
+ }
break;
case REF_SUBSTRING:
&e->where);
}
- if (check_intent_in
- && e->symtree->n.sym->attr.intent == INTENT_IN)
+ if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ sym->name, &e->where);
return FAILURE;
}
+ if (e->ts.type == BT_CLASS)
+ {
+ /* Only deallocate the DATA component. */
+ gfc_add_component_ref (e, "$data");
+ }
+
return SUCCESS;
}
derived types with default initializers, and derived types with allocatable
components that need nullification.) */
-static gfc_expr *
-expr_to_initialize (gfc_expr *e)
+gfc_expr *
+gfc_expr_to_initialize (gfc_expr *e)
{
gfc_expr *result;
gfc_ref *ref;
}
+/* Used in resolve_allocate_expr to check that a allocation-object and
+ a source-expr are conformable. This does not catch all possible
+ cases; in particular a runtime checking is needed. */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ /* First compare rank. */
+ if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ {
+ gfc_error ("Source-expr at %L must be scalar or have the "
+ "same rank as the allocate-object at %L",
+ &e1->where, &e2->where);
+ return FAILURE;
+ }
+
+ if (e1->shape)
+ {
+ int i;
+ mpz_t s;
+
+ mpz_init (s);
+
+ for (i = 0; i < e1->rank; i++)
+ {
+ if (e2->ref->u.ar.end[i])
+ {
+ mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
+ mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_add_ui (s, s, 1);
+ }
+ else
+ {
+ mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ }
+
+ if (mpz_cmp (e1->shape[i], s) != 0)
+ {
+ gfc_error ("Source-expr at %L and allocate-object at %L must "
+ "have the same shape", &e1->where, &e2->where);
+ mpz_clear (s);
+ return FAILURE;
+ }
+ }
+
+ mpz_clear (s);
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in;
+ int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
- gfc_code *init_st;
- gfc_expr *init_e;
gfc_symbol *sym;
gfc_alloc *a;
+ gfc_component *c;
+ gfc_expr *init_e;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
pointer, the next-to-last reference must be a pointer. */
ref2 = NULL;
+ if (e->symtree)
+ sym = e->symtree->n.sym;
+
+ /* Check whether ultimate component is abstract and CLASS. */
+ is_abstract = 0;
if (e->expr_type != EXPR_VARIABLE)
{
}
else
{
- allocatable = e->symtree->n.sym->attr.allocatable;
- pointer = e->symtree->n.sym->attr.pointer;
- dimension = e->symtree->n.sym->attr.dimension;
+ if (sym->ts.type == BT_CLASS)
+ {
+ allocatable = sym->ts.u.derived->components->attr.allocatable;
+ pointer = sym->ts.u.derived->components->attr.pointer;
+ dimension = sym->ts.u.derived->components->attr.dimension;
+ is_abstract = sym->ts.u.derived->components->attr.abstract;
+ }
+ else
+ {
+ allocatable = sym->attr.allocatable;
+ pointer = sym->attr.pointer;
+ dimension = sym->attr.dimension;
+ }
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
break;
case REF_COMPONENT:
- allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
-
- pointer = ref->u.c.component->attr.pointer;
- dimension = ref->u.c.component->attr.dimension;
+ c = ref->u.c.component;
+ if (c->ts.type == BT_CLASS)
+ {
+ allocatable = c->ts.u.derived->components->attr.allocatable;
+ pointer = c->ts.u.derived->components->attr.pointer;
+ dimension = c->ts.u.derived->components->attr.dimension;
+ is_abstract = c->ts.u.derived->components->attr.abstract;
+ }
+ else
+ {
+ allocatable = c->attr.allocatable;
+ pointer = c->attr.pointer;
+ dimension = c->attr.dimension;
+ is_abstract = c->attr.abstract;
+ }
break;
case REF_SUBSTRING:
return FAILURE;
}
- if (check_intent_in
- && e->symtree->n.sym->attr.intent == INTENT_IN)
+ /* Some checks for the SOURCE tag. */
+ if (code->expr3)
{
- gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ /* Check F03:C631. */
+ if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+ {
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "source-expr at %L", &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+
+ /* Check F03:C632 and restriction following Note 6.18. */
+ if (code->expr3->rank > 0
+ && conformable_arrays (code->expr3, e) == FAILURE)
+ return FAILURE;
+
+ /* Check F03:C633. */
+ if (code->expr3->ts.kind != e->ts.kind)
+ {
+ gfc_error ("The allocate-object at %L and the source-expr at %L "
+ "shall have the same kind type parameter",
+ &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+ }
+ else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
+ {
+ gcc_assert (e->ts.type == BT_CLASS);
+ gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
+ "type-spec or SOURCE=", sym->name, &e->where);
return FAILURE;
}
- /* Add default initializer for those derived types that need them. */
- if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
+ if (check_intent_in && sym->attr.intent == INTENT_IN)
+ {
+ gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+
+ if (!code->expr3)
{
- init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr1 = expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
+ /* Add default initializer for those derived types that need them. */
+ if (e->ts.type == BT_DERIVED
+ && (init_e = gfc_default_initializer (&e->ts)))
+ {
+ gfc_code *init_st = gfc_get_code ();
+ init_st->loc = code->loc;
+ init_st->op = EXEC_INIT_ASSIGN;
+ init_st->expr1 = gfc_expr_to_initialize (e);
+ init_st->expr2 = init_e;
+ init_st->next = code->next;
+ code->next = init_st;
+ }
+ else if (e->ts.type == BT_CLASS
+ && ((code->ext.alloc.ts.type == BT_UNKNOWN
+ && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts)))
+ || (code->ext.alloc.ts.type == BT_DERIVED
+ && (init_e = gfc_default_initializer (&code->ext.alloc.ts)))))
+ {
+ gfc_code *init_st = gfc_get_code ();
+ init_st->loc = code->loc;
+ init_st->op = EXEC_INIT_ASSIGN;
+ init_st->expr1 = gfc_expr_to_initialize (e);
+ init_st->expr2 = init_e;
+ init_st->next = code->next;
+ code->next = init_st;
+ }
}
- if (pointer && dimension == 0)
+ if (pointer || dimension == 0)
return SUCCESS;
/* Make sure the next-to-last reference node is an array specification. */
check_symbols:
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
/* TODO - check derived type components. */
- if (sym->ts.type == BT_DERIVED)
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
continue;
if ((ar->start[i] != NULL
gfc_error ("Illegal stat-variable at %L for a PURE procedure",
&stat->where);
- if (stat->ts.type != BT_INTEGER
- && !(stat->ref && (stat->ref->type == REF_ARRAY
- || stat->ref->type == REF_COMPONENT)))
+ if ((stat->ts.type != BT_INTEGER
+ && !(stat->ref && (stat->ref->type == REF_ARRAY
+ || stat->ref->type == REF_COMPONENT)))
+ || stat->rank > 0)
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
"variable", &stat->where);
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
gfc_error ("Stat-variable at %L shall not be %sd within "
"the same %s statement", &stat->where, fcn, fcn);
gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
&errmsg->where);
- if (errmsg->ts.type != BT_CHARACTER
- && !(errmsg->ref
- && (errmsg->ref->type == REF_ARRAY
- || errmsg->ref->type == REF_COMPONENT)))
+ if ((errmsg->ts.type != BT_CHARACTER
+ && !(errmsg->ref
+ && (errmsg->ref->type == REF_ARRAY
+ || errmsg->ref->type == REF_COMPONENT)))
+ || errmsg->rank > 0 )
gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
"variable", &errmsg->where);
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
gfc_error ("Errmsg-variable at %L shall not be %sd within "
"the same %s statement", &errmsg->where, fcn, fcn);
/* Check that an allocate-object appears only once in the statement.
FIXME: Checking derived types is disabled. */
- for (p = code->ext.alloc_list; p; p = p->next)
+ for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
if ((pe->ref && pe->ref->type != REF_COMPONENT)
if (strcmp (fcn, "ALLOCATE") == 0)
{
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
resolve_allocate_expr (a->expr, code);
}
else
{
- for (a = code->ext.alloc_list; a; a = a->next)
+ for (a = code->ext.alloc.list; a; a = a->next)
resolve_deallocate_expr (a->expr);
}
}
}
+/* Check if a derived type is extensible. */
+
+bool
+gfc_type_is_extensible (gfc_symbol *sym)
+{
+ return !(sym->attr.is_bind_c || sym->attr.sequence);
+}
+
+
+/* Resolve a SELECT TYPE statement. */
+
+static void
+resolve_select_type (gfc_code *code)
+{
+ gfc_symbol *selector_type;
+ gfc_code *body, *new_st, *if_st, *tail;
+ gfc_code *class_is = NULL, *default_case = NULL;
+ gfc_case *c;
+ gfc_symtree *st;
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_namespace *ns;
+ int error = 0;
+
+ ns = code->ext.ns;
+ gfc_resolve (ns);
+
+ if (code->expr2)
+ selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ else
+ selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+
+ /* Loop over TYPE IS / CLASS IS cases. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.case_list;
+
+ /* Check F03:C815. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && !gfc_type_is_extensible (c->ts.u.derived))
+ {
+ gfc_error ("Derived type '%s' at %L must be extensible",
+ c->ts.u.derived->name, &c->where);
+ error++;
+ continue;
+ }
+
+ /* Check F03:C816. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
+ {
+ gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
+ c->ts.u.derived->name, &c->where, selector_type->name);
+ error++;
+ continue;
+ }
+
+ /* Intercept the DEFAULT case. */
+ if (c->ts.type == BT_UNKNOWN)
+ {
+ /* Check F03:C818. */
+ if (default_case)
+ {
+ gfc_error ("The DEFAULT CASE at %L cannot be followed "
+ "by a second DEFAULT CASE at %L",
+ &default_case->ext.case_list->where, &c->where);
+ error++;
+ continue;
+ }
+ else
+ default_case = body;
+ }
+ }
+
+ if (error>0)
+ return;
+
+ if (code->expr2)
+ {
+ /* Insert assignment for selector variable. */
+ new_st = gfc_get_code ();
+ new_st->op = EXEC_ASSIGN;
+ new_st->expr1 = gfc_copy_expr (code->expr1);
+ new_st->expr2 = gfc_copy_expr (code->expr2);
+ ns->code = new_st;
+ }
+
+ /* Put SELECT TYPE statement inside a BLOCK. */
+ new_st = gfc_get_code ();
+ new_st->op = code->op;
+ new_st->expr1 = code->expr1;
+ new_st->expr2 = code->expr2;
+ new_st->block = code->block;
+ if (!ns->code)
+ ns->code = new_st;
+ else
+ ns->code->next = new_st;
+ code->op = EXEC_BLOCK;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
+
+ code = new_st;
+
+ /* Transform to EXEC_SELECT. */
+ code->op = EXEC_SELECT;
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, "$hash");
+
+ /* Loop over TYPE IS / CLASS IS cases. */
+ for (body = code->block; body; body = body->block)
+ {
+ c = body->ext.case_list;
+
+ if (c->ts.type == BT_DERIVED)
+ c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+ else if (c->ts.type == BT_UNKNOWN)
+ continue;
+
+ /* Assign temporary to selector. */
+ if (c->ts.type == BT_CLASS)
+ sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+ else
+ sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ new_st = gfc_get_code ();
+ new_st->expr1 = gfc_get_variable_expr (st);
+ new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
+ if (c->ts.type == BT_DERIVED)
+ {
+ new_st->op = EXEC_POINTER_ASSIGN;
+ gfc_add_component_ref (new_st->expr2, "$data");
+ }
+ else
+ new_st->op = EXEC_POINTER_ASSIGN;
+ new_st->next = body->next;
+ body->next = new_st;
+ }
+
+ /* Take out CLASS IS cases for separate treatment. */
+ body = code;
+ while (body && body->block)
+ {
+ if (body->block->ext.case_list->ts.type == BT_CLASS)
+ {
+ /* Add to class_is list. */
+ if (class_is == NULL)
+ {
+ class_is = body->block;
+ tail = class_is;
+ }
+ else
+ {
+ for (tail = class_is; tail->block; tail = tail->block) ;
+ tail->block = body->block;
+ tail = tail->block;
+ }
+ /* Remove from EXEC_SELECT list. */
+ body->block = body->block->block;
+ tail->block = NULL;
+ }
+ else
+ body = body->block;
+ }
+
+ if (class_is)
+ {
+ gfc_symbol *vtab;
+
+ if (!default_case)
+ {
+ /* Add a default case to hold the CLASS IS cases. */
+ for (tail = code; tail->block; tail = tail->block) ;
+ tail->block = gfc_get_code ();
+ tail = tail->block;
+ tail->op = EXEC_SELECT_TYPE;
+ tail->ext.case_list = gfc_get_case ();
+ tail->ext.case_list->ts.type = BT_UNKNOWN;
+ tail->next = NULL;
+ default_case = tail;
+ }
+
+ /* More than one CLASS IS block? */
+ if (class_is->block)
+ {
+ gfc_code **c1,*c2;
+ bool swapped;
+ /* Sort CLASS IS blocks by extension level. */
+ do
+ {
+ swapped = false;
+ for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
+ {
+ c2 = (*c1)->block;
+ /* F03:C817 (check for doubles). */
+ if ((*c1)->ext.case_list->ts.u.derived->hash_value
+ == c2->ext.case_list->ts.u.derived->hash_value)
+ {
+ gfc_error ("Double CLASS IS block in SELECT TYPE "
+ "statement at %L", &c2->ext.case_list->where);
+ return;
+ }
+ if ((*c1)->ext.case_list->ts.u.derived->attr.extension
+ < c2->ext.case_list->ts.u.derived->attr.extension)
+ {
+ /* Swap. */
+ (*c1)->block = c2->block;
+ c2->block = *c1;
+ *c1 = c2;
+ swapped = true;
+ }
+ }
+ }
+ while (swapped);
+ }
+
+ /* Generate IF chain. */
+ if_st = gfc_get_code ();
+ if_st->op = EXEC_IF;
+ new_st = if_st;
+ for (body = class_is; body; body = body->block)
+ {
+ new_st->block = gfc_get_code ();
+ new_st = new_st->block;
+ new_st->op = EXEC_IF;
+ /* Set up IF condition: Call _gfortran_is_extension_of. */
+ new_st->expr1 = gfc_get_expr ();
+ new_st->expr1->expr_type = EXPR_FUNCTION;
+ new_st->expr1->ts.type = BT_LOGICAL;
+ new_st->expr1->ts.kind = 4;
+ new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+ new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
+ new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
+ /* Set up arguments. */
+ new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
+ new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
+ gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+ new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
+ new_st->next = body->next;
+ }
+ if (default_case->next)
+ {
+ new_st->block = gfc_get_code ();
+ new_st = new_st->block;
+ new_st->op = EXEC_IF;
+ new_st->next = default_case->next;
+ }
+
+ /* Replace CLASS DEFAULT code by the IF chain. */
+ default_case->next = if_st;
+ }
+
+ resolve_select (code);
+
+}
+
+
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
-- a derived type being transferred doesn't have private components, unless
}
-/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
+/* Resolve a BLOCK construct statement. */
+
+static void
+resolve_block_construct (gfc_code* code)
+{
+ /* Eventually, we may want to do some checks here or handle special stuff.
+ But so far the only thing we can do is resolving the local namespace. */
+
+ gfc_resolve (code->ext.ns);
+}
+
+
+/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
DO code nodes. */
static void resolve_code (gfc_code *, gfc_namespace *);
resolve_branch (b->label1, b);
break;
+ case EXEC_BLOCK:
+ resolve_block_construct (b);
+ break;
+
case EXEC_SELECT:
+ case EXEC_SELECT_TYPE:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
break;
default:
- gfc_internal_error ("resolve_block(): Bad block type");
+ gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
resolve_code (b->next, ns);
if (gfc_extend_assign (code, ns) == SUCCESS)
{
- lhs = code->ext.actual->expr;
- rhs = code->ext.actual->next->expr;
- if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+ gfc_expr** rhsptr;
+
+ if (code->op == EXEC_ASSIGN_CALL)
{
- gfc_error ("Subroutine '%s' called instead of assignment at "
- "%L must be PURE", code->symtree->n.sym->name,
- &code->loc);
- return rval;
+ lhs = code->ext.actual->expr;
+ rhsptr = &code->ext.actual->next->expr;
+ }
+ else
+ {
+ gfc_actual_arglist* args;
+ gfc_typebound_proc* tbp;
+
+ gcc_assert (code->op == EXEC_COMPCALL);
+
+ args = code->expr1->value.compcall.actual;
+ lhs = args->expr;
+ rhsptr = &args->next->expr;
+
+ tbp = code->expr1->value.compcall.tbp;
+ gcc_assert (!tbp->is_generic);
}
/* Make a temporary rhs when there is a default initializer
and rhs is the same symbol as the lhs. */
- if (rhs->expr_type == EXPR_VARIABLE
- && rhs->symtree->n.sym->ts.type == BT_DERIVED
- && has_default_initializer (rhs->symtree->n.sym->ts.u.derived)
- && (lhs->symtree->n.sym == rhs->symtree->n.sym))
- code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+ if ((*rhsptr)->expr_type == EXPR_VARIABLE
+ && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
+ && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+ && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
+ *rhsptr = gfc_get_parentheses (*rhsptr);
return true;
}
if (rhs->is_boz
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
- "a DATA statement and outside INT/REAL/DBLE/CMPLX",
- &code->loc) == FAILURE)
+ "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+ &code->loc) == FAILURE)
return false;
/* Handle the case of a BOZ literal on the RHS. */
rlen = rhs->value.character.length;
else if (rhs->ts.u.cl != NULL
- && rhs->ts.u.cl->length != NULL
+ && rhs->ts.u.cl->length != NULL
&& rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
+ && rhs->expr_type == EXPR_VARIABLE
&& gfc_impure_variable (rhs->symtree->n.sym))
{
gfc_error ("The impure variable at %L is assigned to "
}
}
+ /* F03:7.4.1.2. */
+ if (lhs->ts.type == BT_CLASS)
+ {
+ gfc_error ("Variable must not be polymorphic in assignment at %L",
+ &lhs->where);
+ return false;
+ }
+
gfc_check_assign (lhs, rhs, 1);
return false;
}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
case EXEC_OMP_DO:
gfc_resolve_omp_do_blocks (code, ns);
break;
+ case EXEC_SELECT_TYPE:
+ gfc_current_ns = code->ext.ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = ns;
+ break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
+ if (code->op == EXEC_ALLOCATE
+ && gfc_resolve_expr (code->expr3) == FAILURE)
+ t = FAILURE;
+
switch (code->op)
{
case EXEC_NOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
+ case EXEC_ASSIGN_CALL:
break;
case EXEC_ENTRY:
break;
if (resolve_ordinary_assign (code, ns))
- goto call;
-
+ {
+ if (code->op == EXEC_COMPCALL)
+ goto compcall;
+ else
+ goto call;
+ }
break;
case EXEC_LABEL_ASSIGN:
break;
case EXEC_COMPCALL:
- resolve_typebound_call (code);
+ compcall:
+ resolve_typebound_subroutine (code);
break;
case EXEC_CALL_PPC:
- resolve_ppc_call (code);
+ resolve_ppc_call (code);
break;
case EXEC_SELECT:
resolve_select (code);
break;
+ case EXEC_SELECT_TYPE:
+ resolve_select_type (code);
+ break;
+
+ case EXEC_BLOCK:
+ gfc_resolve (code->ext.ns);
+ break;
+
case EXEC_DO:
if (code->ext.iterator != NULL)
{
value, the length of character entities declared is zero." */
if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
{
- gfc_warning_now ("CHARACTER variable has zero length at %L",
- &cl->length->where);
+ if (gfc_option.warn_surprising)
+ gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
+ " the length has been set to zero",
+ &cl->length->where, i);
gfc_replace_expr (cl->length, gfc_int_expr (0));
}
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
-#else
- mpfr_init (init_expr->value.complex.r);
- mpfr_init (init_expr->value.complex.i);
-#endif
switch (gfc_option.flag_init_real)
{
case GFC_INIT_REAL_SNAN:
break;
case GFC_INIT_REAL_ZERO:
-#ifdef HAVE_mpc
mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
-#else
- mpfr_set_ui (init_expr->value.complex.r, 0.0, GFC_RND_MODE);
- mpfr_set_ui (init_expr->value.complex.i, 0.0, GFC_RND_MODE);
-#endif
break;
default:
/* For saved variables, we don't want to add an initializer at
function entry, so we just add a static initializer. */
- if (sym->attr.save || sym->ns->save_all)
+ if (sym->attr.save || sym->ns->save_all
+ || gfc_option.flag_max_stack_var_size == 0)
{
/* Don't clobber an existing initializer! */
gcc_assert (sym->value == NULL);
if (sym->attr.allocatable)
{
if (sym->attr.dimension)
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
- else
- gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
- sym->name, &sym->declared_at);
+ {
+ gfc_error ("Allocatable array '%s' at %L must have "
+ "a deferred shape", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
+ "may not be ALLOCATABLE", sym->name,
+ &sym->declared_at) == FAILURE)
return FAILURE;
}
}
else
{
- if (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
+ if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
+ && !sym->attr.dummy && sym->ts.type != BT_CLASS)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
}
-/* Check if a derived type is extensible. */
-
-static bool
-type_is_extensible (gfc_symbol *sym)
-{
- return !(sym->attr.is_bind_c || sym->attr.sequence);
-}
-
-
/* Additional checks for symbols with flavor variable and derived
type. To be called from resolve_fl_variable. */
static gfc_try
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{
- gcc_assert (sym->ts.type == BT_DERIVED);
+ gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
/* Check to see if a derived type is blocked from being host
associated by the presence of another class I symbol in the same
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable
- && has_default_initializer (sym->ts.u.derived))
- {
- gfc_error("Object '%s' at %L must have the SAVE attribute for "
- "default initialization of a component",
- sym->name, &sym->declared_at);
- return FAILURE;
- }
+ && has_default_initializer (sym->ts.u.derived)
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
+ "module variable '%s' at %L, needed due to "
+ "the default initialization", sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
- if (sym->ts.is_class)
+ if (sym->ts.type == BT_CLASS)
{
/* C502. */
- if (!type_is_extensible (sym->ts.u.derived))
+ if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
- sym->ts.u.derived->name, sym->name, &sym->declared_at);
+ sym->ts.u.derived->components->ts.u.derived->name,
+ sym->name, &sym->declared_at);
return FAILURE;
}
/* C509. */
- if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+ /* Assume that use associated symbols were checked in the module ns. */
+ if (!sym->attr.class_ok && !sym->attr.use_assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
}
no_init_error:
- if (sym->ts.type == BT_DERIVED)
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
return resolve_fl_variable_derived (sym, no_init_flag);
return SUCCESS;
{
gfc_formal_arglist *arg;
- if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
- gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
- "interfaces", sym->name, &sym->declared_at);
-
if (sym->attr.function
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
&& resolve_charlen (cl) == FAILURE)
return FAILURE;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ && sym->attr.proc == PROC_ST_FUNCTION)
{
- if (sym->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Character-valued statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- if (sym->attr.external && sym->formal == NULL
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Automatic character length function '%s' at %L must "
- "have an explicit interface", sym->name,
- &sym->declared_at);
- return FAILURE;
- }
+ gfc_error ("Character-valued statement function '%s' at %L must "
+ "have constant length", sym->name, &sym->declared_at);
+ return FAILURE;
}
}
if (proc_pass_arg != argpos && old_pass_arg != argpos
&& !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
{
- gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
- " in respect to the overridden procedure",
+ gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
+ "in respect to the overridden procedure",
proc_formal->sym->name, proc->name, &where);
return FAILURE;
}
sym1 = t1->specific->u.specific->n.sym;
sym2 = t2->specific->u.specific->n.sym;
+ if (sym1 == sym2)
+ return SUCCESS;
+
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
if (sym1->attr.subroutine != sym2->attr.subroutine
|| sym1->attr.function != sym2->attr.function)
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
/* Look for an inherited specific binding. */
if (super_type)
{
- inherited = gfc_find_typebound_proc (super_type, NULL,
- target_name, true);
+ inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
+ true, NULL);
if (inherited)
{
if (super_type)
{
gfc_symtree* overridden;
- overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+ overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
+ true, NULL);
if (overridden && overridden->n.tb)
st->n.tb->overridden = overridden->n.tb;
super_type = gfc_get_derived_super_type (derived);
if (super_type && super_type->f2k_derived)
p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
- op, true);
+ op, true, NULL);
else
p->overridden = NULL;
target_proc = get_checked_tb_operator_target (target, p->where);
if (!target_proc)
- return FAILURE;
+ goto error;
if (!gfc_check_operator_interface (target_proc, op, p->where))
- return FAILURE;
+ goto error;
}
return SUCCESS;
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_user_op (super_type, NULL,
- stree->name, true);
+ stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->overridden = overridden->n.tb;
me_arg = proc->formal->sym;
}
- /* Now check that the argument-type matches. */
+ /* Now check that the argument-type matches and the passed-object
+ dummy argument is generally fine. */
+
gcc_assert (me_arg);
- if (me_arg->ts.type != BT_DERIVED
- || me_arg->ts.u.derived != resolve_bindings_derived)
+
+ if (me_arg->ts.type != BT_CLASS)
+ {
+ gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+ " at %L", proc->name, &where);
+ goto error;
+ }
+
+ if (me_arg->ts.u.derived->components->ts.u.derived
+ != resolve_bindings_derived)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived-type '%s'", me_arg->name, proc->name,
me_arg->name, &where, resolve_bindings_derived->name);
goto error;
}
-
- if (!me_arg->ts.is_class)
+
+ gcc_assert (me_arg->ts.type == BT_CLASS);
+ if (me_arg->ts.u.derived->components->as
+ && me_arg->ts.u.derived->components->as->rank > 0)
{
- gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
- " at %L", proc->name, &where);
+ gfc_error ("Passed-object dummy argument of '%s' at %L must be"
+ " scalar", proc->name, &where);
+ goto error;
+ }
+ if (me_arg->ts.u.derived->components->attr.allocatable)
+ {
+ gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+ " be ALLOCATABLE", proc->name, &where);
+ goto error;
+ }
+ if (me_arg->ts.u.derived->components->attr.class_pointer)
+ {
+ gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+ " be POINTER", proc->name, &where);
goto error;
}
}
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_proc (super_type, NULL,
- stree->name, true);
+ stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->overridden = overridden->n.tb;
resolve_typebound_procedures (gfc_symbol* derived)
{
int op;
- bool found_op;
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
&resolve_typebound_procedure);
- found_op = (derived->f2k_derived->tb_uop_root != NULL);
if (derived->f2k_derived->tb_uop_root)
gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
&resolve_typebound_user_op);
if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
p) == FAILURE)
resolve_bindings_result = FAILURE;
- if (p)
- found_op = true;
- }
-
- /* FIXME: Remove this (and found_op) once calls are fully implemented. */
- if (found_op)
- {
- gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's,"
- " they are not yet implemented.",
- derived->name, &derived->declared_at);
- resolve_bindings_result = FAILURE;
}
return resolve_bindings_result;
if (st->n.tb && st->n.tb->deferred)
{
gfc_symtree* overriding;
- overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
+ overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
gcc_assert (overriding && overriding->n.tb);
if (overriding->n.tb->deferred)
{
return FAILURE;
/* An ABSTRACT type must be extensible. */
- if (sym->attr.abstract && !type_is_extensible (sym))
+ if (sym->attr.abstract && !gfc_type_is_extensible (sym))
{
gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
sym->name, &sym->declared_at);
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- /* TODO: gfc_expr_replace_symbols (c->ts.u.cl->length, c);*/
+ gfc_expr_replace_comp (c->ts.u.cl->length, c);
}
}
else if (c->ts.interface->name[0] != '\0')
}
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
{
- c->ts = *gfc_get_default_type (c->name, NULL);
- c->attr.implicit_type = 1;
+ /* Since PPCs are not implicitly typed, a PPC without an explicit
+ interface must be a subroutine. */
+ gfc_add_subroutine (&c->attr, c->name, &c->loc);
}
/* Procedure pointer components: Check PASS arg. */
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
- if (me_arg->ts.type != BT_DERIVED
- || me_arg->ts.u.derived != sym)
+ if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
+ || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
+ || (me_arg->ts.type == BT_CLASS
+ && me_arg->ts.u.derived->components->ts.u.derived != sym))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived type '%s'", me_arg->name, c->name,
return FAILURE;
}
- if (type_is_extensible (sym) && !me_arg->ts.is_class)
+ if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
- " at %L", c->name, &c->loc);
+ " at %L", c->name, &c->loc);
}
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
return FAILURE;
+ /* If this type is an extension, set the accessibility of the parent
+ component. */
+ if (super_type && c == sym->components
+ && strcmp (super_type->name, c->name) == 0)
+ c->attr.access = super_type->attr.access;
+
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
if (super_type
- && gfc_find_typebound_proc (super_type, NULL, c->name, true))
+ && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
" inherited type-bound procedure",
return FAILURE;
}
- if (c->ts.type == BT_CHARACTER)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
}
/* C437. */
- if (c->ts.type == BT_DERIVED && c->ts.is_class
- && !(c->attr.pointer || c->attr.allocatable))
+ if (c->ts.type == BT_CLASS
+ && !(c->ts.u.derived->components->attr.pointer
+ || c->ts.u.derived->components->attr.allocatable))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
/* Resolve formal namespaces. */
if (sym->formal_ns && sym->formal_ns != gfc_current_ns
- && !sym->attr.contained)
+ && !sym->attr.contained && !sym->attr.intrinsic)
gfc_resolve (sym->formal_ns);
/* Make sure the formal namespace is present. */
{
while (mpz_cmp_ui (values.left, 0) == 0)
{
- if (!gfc_is_constant_expr (values.vnode->expr))
- gfc_error ("non-constant DATA value at %L",
- &values.vnode->expr->where);
if (values.vnode->next == NULL)
return FAILURE;
gfc_impure_variable (gfc_symbol *sym)
{
gfc_symbol *proc;
+ gfc_namespace *ns;
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
- if (sym->ns != gfc_current_ns)
- return !sym->attr.function;
+ /* Check if the symbol's ns is inside the pure procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ if (ns == sym->ns)
+ break;
+ if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+ return 1;
+ }
proc = sym->ns->proc_name;
if (sym->attr.dummy && gfc_pure (proc)
}
-/* Test whether a symbol is pure or not. For a NULL pointer, checks the
- symbol of the current procedure. */
+/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
+ current namespace is inside a pure procedure. */
int
gfc_pure (gfc_symbol *sym)
{
symbol_attribute attr;
+ gfc_namespace *ns;
if (sym == NULL)
- sym = gfc_current_ns->proc_name;
- if (sym == NULL)
- return 0;
+ {
+ /* Check if the current namespace or one of its parents
+ belongs to a pure procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
+ return 1;
+ }
+ return 0;
+ }
attr = sym->attr;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
int object, cnt_protected;
- const char *value_name;
const char *msg;
- value_name = NULL;
last_ts = &eq->expr->symtree->n.sym->ts;
first_sym = eq->expr->symtree->n.sym;
resolve_codes (n);
gfc_current_ns = ns;
- cs_base = NULL;
+
+ /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
+ if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
+ cs_base = NULL;
+
/* Set to an out of range value. */
current_entry_id = -1;
OSDN Git Service
