/* 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
#include "dependency.h"
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
+#include "constructor.h"
/* Types used in equivalence statements. */
/* We use bitmaps to determine if a branch target is valid. */
static bitmap_obstack labels_obstack;
+/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
+static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_int_expr (1);
+ sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
if (gfc_elemental (proc))
{
+ /* F2008, C1289. */
+ if (sym->attr.codimension)
+ {
+ gfc_error ("Coarray dummy argument '%s' at %L to elemental "
+ "procedure", sym->name, &sym->declared_at);
+ continue;
+ }
+
if (sym->as != NULL)
{
gfc_error ("Argument '%s' of elemental procedure at %L must "
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);
symbol_attribute a;
t = SUCCESS;
- cons = expr->value.constructor;
+ cons = gfc_constructor_first (expr->value.constructor);
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
/* 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;
}
- for (; comp; comp = comp->next, cons = cons->next)
+ /* 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 && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
"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)
+ || gfc_is_coindexed (cons->expr)))
+ {
+ 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 || a.codimension)
return 1;
return 0;
gfc_symbol* context_proc;
gfc_namespace* real_context;
+ if (sym->attr.flavor == FL_PROGRAM)
+ return false;
+
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
/* If we've got an ENTRY, find real procedure. */
gfc_expr *e;
int save_need_full_assumed_size;
gfc_component *comp;
-
+
for (; arg; arg = arg->next)
{
e = arg->expr;
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. */
}
}
}
+
+ /* Fortran 2008, C1237. */
+ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ "component", &e->where);
+ return FAILURE;
+ }
}
return SUCCESS;
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 != NULL
+ && 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 (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
+ if (expr->value.function.isym && expr->value.function.isym->inquiry)
+ inquiry_argument = true;
no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+
if (resolve_actual_arglist (expr->value.function.actual,
p, no_formal_args) == FAILURE)
+ {
+ inquiry_argument = false;
return FAILURE;
+ }
+ inquiry_argument = false;
+
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
}
}
+ /* 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;
{
mpz_t last_value;
+ if (ar->dimen_type[i] == DIMEN_STAR)
+ {
+ gcc_assert (ar->stride[i] == NULL);
+ /* This implies [*] as [*:] and [*:3] are not possible. */
+ if (ar->start[i] == NULL)
+ {
+ gcc_assert (ar->end[i] == NULL);
+ return SUCCESS;
+ }
+ }
+
/* Given start, end and stride values, calculate the minimum and
maximum referenced indexes. */
case DIMEN_VECTOR:
break;
+ case DIMEN_STAR:
case DIMEN_ELEMENT:
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld < %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->lower[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld > %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->upper[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
return FAILURE;
}
+ /* ar->codimen == 0 is a local array. */
+ if (as->corank != ar->codimen && ar->codimen != 0)
+ {
+ gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
+ &ar->where, ar->codimen, as->corank);
+ return FAILURE;
+ }
+
for (i = 0; i < as->rank; i++)
if (check_dimension (i, ar, as) == FAILURE)
return FAILURE;
+ /* Local access has no coarray spec. */
+ if (ar->codimen != 0)
+ for (i = as->rank; i < as->rank + as->corank; i++)
+ {
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ {
+ gfc_error ("Coindex of codimension %d must be a scalar at %L",
+ i + 1 - as->rank, &ar->where);
+ return FAILURE;
+ }
+ if (check_dimension (i, ar, as) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
/* Resolve one part of an array index. */
-gfc_try
-gfc_resolve_index (gfc_expr *index, int check_scalar)
+static gfc_try
+gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
+ int force_index_integer_kind)
{
gfc_typespec ts;
&index->where) == FAILURE)
return FAILURE;
- if (index->ts.kind != gfc_index_integer_kind
+ if ((index->ts.kind != gfc_index_integer_kind
+ && force_index_integer_kind)
|| index->ts.type != BT_INTEGER)
{
gfc_clear_ts (&ts);
return SUCCESS;
}
+/* Resolve one part of an array index. */
+
+gfc_try
+gfc_resolve_index (gfc_expr *index, int check_scalar)
+{
+ return gfc_resolve_index_1 (index, check_scalar, 1);
+}
+
/* Resolve a dim argument to an intrinsic function. */
gfc_try
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
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)
int i, check_scalar;
gfc_expr *e;
- for (i = 0; i < ar->dimen; i++)
+ for (i = 0; i < ar->dimen + ar->codimen; i++)
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
- if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
+ /* Do not force gfc_index_integer_kind for the start. We can
+ do fine with any integer kind. This avoids temporary arrays
+ created for indexing with a vector. */
+ if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
return FAILURE;
if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
return FAILURE;
}
}
+ if (ar->type == AR_FULL && ar->as->rank == 0)
+ ar->type = AR_ELEMENT;
+
/* If the reference type is unknown, figure out what kind it is. */
if (ar->type == AR_UNKNOWN)
if (char_ref->u.ss.start)
start = gfc_copy_expr (char_ref->u.ss.start);
else
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
if (char_ref->u.ss.end)
end = gfc_copy_expr (char_ref->u.ss.end);
/* Length = (end - start +1). */
e->ts.u.cl->length = gfc_subtract (end, start);
- e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1));
e->ts.u.cl->length->ts.type = BT_INTEGER;
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
switch (ref->u.ar.type)
{
case AR_FULL:
+ /* Coarray scalar. */
+ if (ref->u.ar.as->rank == 0)
+ {
+ current_part_dimension = 0;
+ break;
+ }
+ /* Fall through. */
case AR_SECTION:
current_part_dimension = 1;
break;
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 "
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
t = FAILURE;
+ /* F2008, C617 and C1229. */
+ if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
+ && gfc_is_coindexed (e))
+ {
+ gfc_ref *ref, *ref2 = NULL;
+
+ if (e->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic subobject of coindexed object at %L",
+ &e->where);
+ t = FAILURE;
+ }
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT)
+ ref2 = ref;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ break;
+ }
+
+ for ( ; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ break;
+
+ /* Expression itself is coindexed object. */
+ if (ref == NULL)
+ {
+ gfc_component *c;
+ c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+ for ( ; c; c = c->next)
+ if (c->attr.allocatable && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Coindexed object with polymorphic allocatable "
+ "subcomponent at %L", &e->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
return t;
}
if (op1->ts.u.cl && op1->ts.u.cl->length)
e1 = gfc_copy_expr (op1->ts.u.cl->length);
else if (op1->expr_type == EXPR_CONSTANT)
- e1 = gfc_int_expr (op1->value.character.length);
+ e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ op1->value.character.length);
if (op2->ts.u.cl && op2->ts.u.cl->length)
e2 = gfc_copy_expr (op2->ts.u.cl->length);
else if (op2->expr_type == EXPR_CONSTANT)
- e2 = gfc_int_expr (op2->value.character.length);
+ e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ op2->value.character.length);
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
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)
if (!po)
return FAILURE;
- if (po->rank > 0)
- {
- gfc_error ("Passed-object at %L must be scalar", &e->where);
- return FAILURE;
- }
-
if (tbp->nopass || e->value.compcall.ignore_pass)
{
gfc_free_expr (po);
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;
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;
}
resolving subroutine class methods, since we do not have to add a
gfc_code each time. */
static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn)
+resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
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->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
- /* Resolution is not necessary if this is a class subroutine; this
- function only has to identify the specific proc. Resolution of
- the call will be done next in resolve_typebound_call. */
- return fcn ? gfc_resolve_expr (e) : SUCCESS;
+ /* 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;
}
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 check_class_members (gfc_symbol *);
static gfc_try class_try;
static bool fcn_flag;
-static gfc_symbol *class_object;
static void
check_members (gfc_symbol *derived)
{
if (derived->attr.flavor == FL_DERIVED)
- check_class_members (derived);
+ (void) check_class_members (derived);
}
-static void
+static gfc_try
check_class_members (gfc_symbol *derived)
{
- gfc_symbol* tbp_sym;
gfc_expr *e;
gfc_symtree *tbp;
gfc_class_esym_list *etmp;
{
gfc_error ("no typebound available procedure named '%s' at %L",
e->value.compcall.name, &e->where);
- return;
+ return FAILURE;
}
- if (tbp->n.tb->is_generic)
+ /* If we have to match a passed class member, force the actual
+ expression to have the correct type. */
+ if (!tbp->n.tb->nopass)
{
- tbp_sym = NULL;
+ if (e->value.compcall.base_object == NULL)
+ e->value.compcall.base_object = extract_compcall_passed_object (e);
- /* 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 (e->value.compcall.base_object == NULL)
+ return FAILURE;
- e->value.compcall.base_object->ts.type = BT_DERIVED;
- e->value.compcall.base_object->ts.u.derived = derived;
+ if (!derived->attr.abstract)
+ {
+ e->value.compcall.base_object->ts.type = BT_DERIVED;
+ e->value.compcall.base_object->ts.u.derived = derived;
}
}
- else
- tbp_sym = tbp->n.tb->u.specific->n.sym;
e->value.compcall.tbp = tbp->n.tb;
e->value.compcall.name = tbp->name;
/* Do the renaming, PASSing, generic => specific and other
good things for each class member. */
- class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+ class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
? class_try : FAILURE;
/* Now transfer the found symbol to the esym list. */
/* Burrow down into grandchildren types. */
if (derived->f2k_derived)
gfc_traverse_ns (derived->f2k_derived, check_members);
+
+ return SUCCESS;
}
}
-/* Generate an expression for the vindex, given the reference to
+/* 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*
-vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
- gfc_symbol *declared, gfc_symtree *st)
+hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
{
- gfc_expr *vindex;
- gfc_ref *ref;
+ gfc_expr *hash_value;
- /* Build an expression for the correct vindex; ie. that of the last
+ /* Build an expression for the correct hash_value; ie. that of the last
CLASS reference. */
- ref = gfc_get_ref();
- ref->type = REF_COMPONENT;
- ref->u.c.component = declared->components->next;
- ref->u.c.sym = declared;
- ref->next = NULL;
if (class_ref)
{
- class_ref->next = ref;
+ class_ref->next = NULL;
}
else
{
gfc_free_ref_list (new_ref);
- new_ref = ref;
+ new_ref = NULL;
}
- vindex = gfc_get_expr ();
- vindex->expr_type = EXPR_VARIABLE;
- vindex->symtree = st;
- vindex->symtree->n.sym->refs++;
- vindex->ts = ref->u.c.component->ts;
- vindex->ref = new_ref;
+ 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 vindex;
+ return hash_value;
}
}
-/* Resolve a CLASS typebound function, or 'method'. */
+/* 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_class_compcall (gfc_expr* e)
+resolve_typebound_function (gfc_expr* e)
{
gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_symtree *st;
st = e->symtree;
- class_object = st->n.sym;
+ 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)
+ 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);
+ return resolve_compcall (e, true, false);
}
/* Resolve the argument expressions, */
class_try = SUCCESS;
fcn_flag = true;
list_e = gfc_copy_expr (e);
- check_class_members (derived);
- class_try = (resolve_compcall (e, true) == SUCCESS)
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
+
+ class_try = (resolve_compcall (e, true, false) == SUCCESS)
? class_try : FAILURE;
/* Transfer the class list to the original expression. Note that
resolve_class_esym (e);
/* More than one typebound procedure so transmit an expression for
- the vindex as the selector. */
+ the hash_value as the selector. */
if (e->value.function.class_esym != NULL)
- e->value.function.class_esym->vindex
- = vindex_expr (class_ref, new_ref, declared, st);
+ e->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
return class_try;
}
-/* Resolve a CLASS typebound subroutine, or 'method'. */
+/* 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_class_typebound_call (gfc_code *code)
+resolve_typebound_subroutine (gfc_code *code)
{
gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_symtree *st;
st = code->expr1->symtree;
- class_object = st->n.sym;
+ 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)
+ 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);
class_try = SUCCESS;
fcn_flag = false;
list_e = gfc_copy_expr (code->expr1);
- check_class_members (derived);
+
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
class_try = (resolve_typebound_call (code) == SUCCESS)
? class_try : FAILURE;
resolve_class_esym (code->expr1);
/* More than one typebound procedure so transmit an expression for
- the vindex as the selector. */
+ the hash_value as the selector. */
if (code->expr1->value.function.class_esym != NULL)
- code->expr1->value.function.class_esym->vindex
- = vindex_expr (class_ref, new_ref, declared, st);
+ code->expr1->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
return class_try;
}
}
+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. */
+ con = gfc_constructor_first (e->value.constructor);
+ for (; con; con = gfc_constructor_next (con))
+ {
+ 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. */
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
+ bool inquiry_save;
if (e == NULL)
return SUCCESS;
+ /* inquiry_argument only applies to variables. */
+ inquiry_save = inquiry_argument;
+ if (e->expr_type != EXPR_VARIABLE)
+ inquiry_argument = false;
+
switch (e->expr_type)
{
case EXPR_OP:
break;
case EXPR_COMPCALL:
- if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- t = resolve_class_compcall (e);
- else
- t = resolve_compcall (e, true);
+ 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;
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
fixup_charlen (e);
+ inquiry_argument = inquiry_save;
+
return t;
}
}
+/* 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. */
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
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;
+ /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
+ checking of coarrays. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+
+ if (ref && ref->type == REF_ARRAY)
+ ref->u.ar.in_allocate = true;
+
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
+ codimension = attr.codimension;
}
else
{
allocatable = sym->ts.u.derived->components->attr.allocatable;
pointer = sym->ts.u.derived->components->attr.pointer;
dimension = sym->ts.u.derived->components->attr.dimension;
+ codimension = sym->ts.u.derived->components->attr.codimension;
is_abstract = sym->ts.u.derived->components->attr.abstract;
}
else
allocatable = sym->attr.allocatable;
pointer = sym->attr.pointer;
dimension = sym->attr.dimension;
+ codimension = sym->attr.codimension;
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
break;
case REF_COMPONENT:
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("Coindexed allocatable object at %L",
+ &e->where);
+ goto failure;
+ }
+
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;
+ codimension = c->ts.u.derived->components->attr.codimension;
is_abstract = c->ts.u.derived->components->attr.abstract;
}
else
allocatable = c->attr.allocatable;
pointer = c->attr.pointer;
dimension = c->attr.dimension;
+ codimension = c->attr.codimension;
is_abstract = c->attr.abstract;
}
break;
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
- return FAILURE;
+ goto failure;
}
- if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN)
+ /* Some checks for the SOURCE tag. */
+ if (code->expr3)
+ {
+ /* 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);
+ goto failure;
+ }
+
+ /* Check F03:C632 and restriction following Note 6.18. */
+ if (code->expr3->rank > 0
+ && conformable_arrays (code->expr3, e) == FAILURE)
+ goto 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);
+ goto 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;
+ goto failure;
}
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;
+ goto failure;
+ }
+
+ if (!code->expr3)
+ {
+ /* 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)
- return SUCCESS;
+ if (pointer || (dimension == 0 && codimension == 0))
+ goto success;
/* Make sure the next-to-last reference node is an array specification. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
+ if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ || (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
- return FAILURE;
+ goto failure;
}
/* Make sure that the array section reference makes sense in the
ar = &ref2->u.ar;
+ if (codimension && ar->codimen == 0)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+
for (i = 0; i < ar->dimen; i++)
{
if (ref2->u.ar.type == AR_ELEMENT)
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
+ case DIMEN_STAR:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
- return FAILURE;
+ goto failure;
}
check_symbols:
-
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 ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
- return FAILURE;
+ goto failure;
+ }
+ }
+ }
+
+ for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_ELEMENT
+ || ar->dimen_type[i] == DIMEN_RANGE)
+ {
+ if (i == (ar->dimen + ar->codimen - 1))
+ {
+ gfc_error ("Expected '*' in coindex specification in ALLOCATE "
+ "statement at %L", &e->where);
+ goto failure;
}
+ break;
}
+
+ if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
+ && ar->stride[i] == NULL)
+ break;
+
+ gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+ }
+
+ if (codimension)
+ {
+ gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
+ "at %L", &e->where);
+ goto failure;
}
+success:
return SUCCESS;
+
+failure:
+ return FAILURE;
}
static void
resolve_select_type (gfc_code *code)
{
gfc_symbol *selector_type;
- gfc_code *body, *new_st;
- gfc_case *c, *default_case;
+ 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);
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
- /* Assume there is no DEFAULT case. */
- default_case = NULL;
-
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
{
gfc_error ("Derived type '%s' at %L must be extensible",
c->ts.u.derived->name, &c->where);
+ error++;
continue;
}
{
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;
}
if (c->ts.type == BT_UNKNOWN)
{
/* Check F03:C818. */
- if (default_case != NULL)
- gfc_error ("The DEFAULT CASE at %L cannot be followed "
- "by a second DEFAULT CASE at %L",
- &default_case->where, &c->where);
+ 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 = c;
- continue;
+ default_case = body;
}
}
+
+ if (error>0)
+ return;
if (code->expr2)
{
/* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
- gfc_add_component_ref (code->expr1, "$vindex");
+ 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->vindex);
- else if (c->ts.type == BT_CLASS)
- /* Currently IS CLASS blocks are simply ignored.
- TODO: Implement IS CLASS. */
- c->unreachable = 1;
+ c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c->ts.u.derived->hash_value);
- if (c->ts.type != BT_DERIVED)
+ else if (c->ts.type == BT_UNKNOWN)
continue;
+
/* Assign temporary to selector. */
- sprintf (name, "tmp$%s", c->ts.u.derived->name);
+ 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->op = EXEC_POINTER_ASSIGN;
new_st->expr1 = gfc_get_variable_expr (st);
new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
- gfc_add_component_ref (new_st->expr2, "$data");
+ 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;
+ }
- /* Eliminate dead blocks. */
- for (body = code; body && body->block; body = body->block)
+ if (class_is)
{
- if (body->block->ext.case_list->unreachable)
+ 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)
{
- /* Cut the unreachable block from the code chain. */
- gfc_code *cd = body->block;
- body->block = cd->block;
- /* Kill the dead block, but not the blocks below it. */
- cd->block = NULL;
- gfc_free_statements (cd);
+ 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);
}
}
+
+static void
+resolve_sync (gfc_code *code)
+{
+ /* Check imageset. The * case matches expr1 == NULL. */
+ if (code->expr1)
+ {
+ if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
+ gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
+ "INTEGER expression", &code->expr1->where);
+ if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
+ && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
+ gfc_error ("Imageset argument at %L must between 1 and num_images()",
+ &code->expr1->where);
+ else if (code->expr1->expr_type == EXPR_ARRAY
+ && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
+ {
+ gfc_constructor *cons;
+ cons = gfc_constructor_first (code->expr1->value.constructor);
+ for (; cons; cons = gfc_constructor_next (cons))
+ if (cons->expr->expr_type == EXPR_CONSTANT
+ && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
+ gfc_error ("Imageset argument at %L must between 1 and "
+ "num_images()", &cons->expr->where);
+ }
+ }
+
+ /* Check STAT. */
+ if (code->expr2
+ && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+ || code->expr2->expr_type != EXPR_VARIABLE))
+ gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+ &code->expr2->where);
+
+ /* Check ERRMSG. */
+ if (code->expr3
+ && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+ || code->expr3->expr_type != EXPR_VARIABLE))
+ gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+ &code->expr3->where);
+}
+
+
/* Given a branch to a label, see if the branch is conforming.
The code node describes where the branch is located. */
the bitmap reachable_labels. */
if (bitmap_bit_p (cs_base->reachable_labels, label->value))
- return;
+ {
+ /* Check now whether there is a CRITICAL construct; if so, check
+ whether the label is still visible outside of the CRITICAL block,
+ which is invalid. */
+ for (stack = cs_base; stack; stack = stack->prev)
+ if (stack->current->op == EXEC_CRITICAL
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+ " at %L", &code->loc, &label->where);
+
+ return;
+ }
/* Step four: If we haven't found the label in the bitmap, it may
still be the label of the END of the enclosing block, in which
case we find it by going up the code_stack. */
for (stack = cs_base; stack; stack = stack->prev)
- if (stack->current->next && stack->current->next->here == label)
- break;
+ {
+ if (stack->current->next && stack->current->next->here == label)
+ break;
+ if (stack->current->op == EXEC_CRITICAL)
+ {
+ /* Note: A label at END CRITICAL does not leave the CRITICAL
+ construct as END CRITICAL is still part of it. */
+ gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+ " at %L", &code->loc, &label->where);
+ return;
+ }
+ }
if (stack)
{
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
if (gfc_extend_assign (code, ns) == SUCCESS)
{
- gfc_symbol* assign_proc;
gfc_expr** rhsptr;
if (code->op == EXEC_ASSIGN_CALL)
{
lhs = code->ext.actual->expr;
rhsptr = &code->ext.actual->next->expr;
- assign_proc = code->symtree->n.sym;
}
else
{
tbp = code->expr1->value.compcall.tbp;
gcc_assert (!tbp->is_generic);
- assign_proc = tbp->u.specific->n.sym;
}
/* Make a temporary rhs when there is a default initializer
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
- && gfc_impure_variable (rhs->symtree->n.sym))
+ && rhs->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ {
+ /* F2008, C1283. */
+ if (gfc_is_coindexed (rhs))
+ gfc_error ("Coindexed expression at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure",
+ &rhs->where);
+ else
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &rhs->where);
+ return rval;
+ }
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
{
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
- &rhs->where);
+ gfc_error ("Assignment to coindexed variable at %L in a PURE "
+ "procedure", &rhs->where);
return rval;
}
}
/* F03:7.4.1.2. */
+ /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
+ and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
if (lhs->ts.type == BT_CLASS)
{
gfc_error ("Variable must not be polymorphic in assignment at %L",
return false;
}
+ /* F2008, Section 7.2.1.2. */
+ if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+ {
+ gfc_error ("Coindexed variable must not be have an allocatable ultimate "
+ "component in assignment at %L", &lhs->where);
+ return false;
+ }
+
gfc_check_assign (lhs, rhs, 1);
return false;
}
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_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
+ case EXEC_ERROR_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_ASSIGN_CALL:
+ case EXEC_CRITICAL:
+ break;
+
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
+ resolve_sync (code);
break;
case EXEC_ENTRY:
case EXEC_COMPCALL:
compcall:
- if (code->expr1->symtree
- && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
- resolve_class_typebound_call (code);
- else
- resolve_typebound_call (code);
+ resolve_typebound_subroutine (code);
break;
case EXEC_CALL_PPC:
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);
- gfc_replace_expr (cl->length, gfc_int_expr (0));
+ 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_get_int_expr (gfc_default_integer_kind, NULL, 0));
}
/* Check that the character length is not too large. */
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
has not been simplified; parameter array references. Do the
simplification now. */
- for (i = 0; i < sym->as->rank; i++)
+ for (i = 0; i < sym->as->rank + sym->as->corank; i++)
{
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
not_constant = true;
-
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
return NULL;
/* Now we'll try to build an initializer expression. */
- init_expr = gfc_get_expr ();
- init_expr->expr_type = EXPR_CONSTANT;
- init_expr->ts.type = sym->ts.type;
- init_expr->ts.kind = sym->ts.kind;
- init_expr->where = sym->declared_at;
-
+ init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
+ &sym->declared_at);
+
/* We will only initialize integers, reals, complex, logicals, and
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
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);
&& 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.type == BT_CLASS)
{
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;
}
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
no_init_flag = 1;
- else if (sym->attr.dimension && !sym->attr.pointer
+ else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
no_init_flag = automatic_flag = 1;
{
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;
}
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, NULL, 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);
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_CLASS)
{
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
me_arg->name, &where, resolve_bindings_derived->name);
goto error;
}
-
+
+ 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 ("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;
+ }
}
/* If we are extending some type, check that we don't override a procedure
{
gfc_symtree* overriding;
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
- gcc_assert (overriding && overriding->n.tb);
+ if (!overriding)
+ return FAILURE;
+ gcc_assert (overriding->n.tb);
if (overriding->n.tb->deferred)
{
gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
super_type = gfc_get_derived_super_type (sym);
+ /* F2008, C432. */
+ if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+ {
+ gfc_error ("As extending type '%s' at %L has a coarray component, "
+ "parent type '%s' shall also have one", sym->name,
+ &sym->declared_at, super_type->name);
+ return FAILURE;
+ }
+
/* Ensure the extended type gets resolved before we do. */
if (super_type && resolve_fl_derived (super_type) == FAILURE)
return FAILURE;
for (c = sym->components; c != NULL; c = c->next)
{
+ /* F2008, C442. */
+ if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
+ && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
+ {
+ gfc_error ("Coarray component '%s' at %L must be allocatable with "
+ "deferred shape", c->name, &c->loc);
+ return FAILURE;
+ }
+
+ /* F2008, C443. */
+ if (c->attr.codimension && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->ts.is_iso_c)
+ {
+ gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ "shall not be a coarray", c->name, &c->loc);
+ return FAILURE;
+ }
+
+ /* F2008, C444. */
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+ && (c->attr.codimension || c->attr.pointer || c->attr.dimension
+ || c->attr.allocatable))
+ {
+ gfc_error ("Component '%s' at %L with coarray component "
+ "shall be a nonpointer, nonallocatable scalar",
+ c->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->attr.proc_pointer && c->ts.interface)
{
if (c->ts.interface->attr.procedure)
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
- c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- gfc_expr_replace_comp (c->ts.u.cl->length, c);
+ gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+ gfc_expr_replace_comp (cl->length, c);
+ if (cl->length && !cl->resolved
+ && gfc_resolve_expr (cl->length) == FAILURE)
+ return FAILURE;
+ c->ts.u.cl = cl;
}
}
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. */
&& 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
{
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
+ if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
+ && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
+ return;
}
}
else if (sym->ts.interface->name[0] != '\0')
arguments. */
if (sym->as != NULL
- && (sym->as->type == AS_ASSUMED_SIZE
+ && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
}
}
+ /* F2008, C526. */
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || sym->attr.codimension)
+ && sym->attr.result)
+ gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+ "a coarray component", sym->name, &sym->declared_at);
+
+ /* F2008, C524. */
+ if (sym->attr.codimension && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->ts.is_iso_c)
+ gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ "shall not be a coarray", sym->name, &sym->declared_at);
+
+ /* F2008, C525. */
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
+ && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
+ || sym->attr.allocatable))
+ gfc_error ("Variable '%s' at %L with coarray component "
+ "shall be a nonpointer, nonallocatable scalar",
+ sym->name, &sym->declared_at);
+
+ /* F2008, C526. The function-result case was handled above. */
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || sym->attr.codimension)
+ && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+ || sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program
+ || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
+ gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
+ "component and is not ALLOCATABLE, SAVE nor a "
+ "dummy argument", sym->name, &sym->declared_at);
+ /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
+ else if (sym->attr.codimension && !sym->attr.allocatable
+ && sym->as && sym->as->cotype == AS_DEFERRED)
+ gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
+ "deferred shape", sym->name, &sym->declared_at);
+ else if (sym->attr.codimension && sym->attr.allocatable
+ && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
+ gfc_error ("Allocatable coarray variable '%s' at %L must have "
+ "deferred shape", sym->name, &sym->declared_at);
+
+
+ /* F2008, C541. */
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->attr.codimension && sym->attr.allocatable))
+ && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+ gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+ "allocatable coarray or have coarray components",
+ sym->name, &sym->declared_at);
+
+ if (sym->attr.codimension && sym->attr.dummy
+ && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
+ gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+ "procedure '%s'", sym->name, &sym->declared_at,
+ sym->ns->proc_name->name);
+
switch (sym->attr.flavor)
{
case FL_VARIABLE:
{
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;
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("DATA element '%s' at %L cannot have a coindex",
+ sym->name, where);
+ return FAILURE;
+ }
+
if (has_pointer
&& ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL)
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;
{
ref->type = REF_SUBSTRING;
if (start == NULL)
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
ref->u.ss.start = start;
if (end == NULL && e->ts.u.cl)
end = gfc_copy_expr (e->ts.u.cl->length);
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
