#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "dependency.h"
typedef enum seq_type
{
SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
}
seq_type;
typedef struct code_stack
{
struct gfc_code *head, *current;
struct code_stack *prev;
}
code_stack;
static code_stack *cs_base = NULL;
static int forall_flag;
static int omp_workshare_flag;
static int formal_arg_flag = 0;
static int specification_expr = 0;
static int current_entry_id;
int
gfc_is_formal_arg (void)
{
return formal_arg_flag;
}
static void
resolve_formal_arglist (gfc_symbol * proc)
{
gfc_formal_arglist *f;
gfc_symbol *sym;
int i;
if (proc->result != NULL)
sym = proc->result;
else
sym = proc;
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
|| (sym->as && sym->as->rank > 0))
proc->attr.always_explicit = 1;
formal_arg_flag = 1;
for (f = proc->formal; f; f = f->next)
{
sym = f->sym;
if (sym == NULL)
{
if (gfc_elemental (proc))
gfc_error ("Alternate return specifier in elemental subroutine "
"'%s' at %L is not allowed", proc->name,
&proc->declared_at);
if (proc->attr.function)
gfc_error ("Alternate return specifier in function "
"'%s' at %L is not allowed", proc->name,
&proc->declared_at);
continue;
}
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
{
if (gfc_pure (proc) && !gfc_pure (sym))
{
gfc_error
("Dummy procedure '%s' of PURE procedure at %L must also "
"be PURE", sym->name, &sym->declared_at);
continue;
}
if (gfc_elemental (proc))
{
gfc_error
("Dummy procedure at %L not allowed in ELEMENTAL procedure",
&sym->declared_at);
continue;
}
if (sym->attr.function
&& sym->ts.type == BT_UNKNOWN
&& sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->name);
if (isym == NULL || !isym->specific)
{
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&sym->declared_at);
}
sym->ts = isym->ts;
}
continue;
}
if (sym->ts.type == BT_UNKNOWN)
{
if (!sym->attr.function || sym->result == sym)
gfc_set_default_type (sym, 1, sym->ns);
}
gfc_resolve_array_spec (sym->as, 0);
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
&& !(sym->attr.pointer || sym->attr.allocatable))
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
sym->as->lower[i] = gfc_int_expr (1);
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| sym->attr.optional)
proc->attr.always_explicit = 1;
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc) && !sym->attr.pointer
&& sym->attr.flavor != FL_PROCEDURE)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN)
gfc_error ("Argument '%s' of pure function '%s' at %L must be "
"INTENT(IN)", sym->name, proc->name,
&sym->declared_at);
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
"have its INTENT specified", sym->name, proc->name,
&sym->declared_at);
}
if (gfc_elemental (proc))
{
if (sym->as != NULL)
{
gfc_error
("Argument '%s' of elemental procedure at %L must be scalar",
sym->name, &sym->declared_at);
continue;
}
if (sym->attr.pointer)
{
gfc_error
("Argument '%s' of elemental procedure at %L cannot have "
"the POINTER attribute", sym->name, &sym->declared_at);
continue;
}
}
if (proc->attr.proc == PROC_ST_FUNCTION)
{
if (sym->as != NULL)
{
gfc_error
("Argument '%s' of statement function at %L must be scalar",
sym->name, &sym->declared_at);
continue;
}
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error
("Character-valued argument '%s' of statement function at "
"%L must have constant length",
sym->name, &sym->declared_at);
continue;
}
}
}
}
formal_arg_flag = 0;
}
static void
find_arglists (gfc_symbol * sym)
{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
return;
resolve_formal_arglist (sym);
}
static void
resolve_formal_arglists (gfc_namespace * ns)
{
if (ns == NULL)
return;
gfc_traverse_ns (ns, find_arglists);
}
static void
resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
{
try t;
if (! sym
|| !(sym->attr.function
|| sym->attr.flavor == FL_VARIABLE))
return;
if (sym->result != NULL)
sym = sym->result;
if (sym->ts.type == BT_UNKNOWN)
{
t = gfc_set_default_type (sym, 0, ns);
if (t == FAILURE && !sym->attr.untyped)
{
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
sym->attr.untyped = 1;
}
}
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.cl;
if (!cl || !cl->length)
gfc_error ("Character-valued internal function '%s' at %L must "
"not be assumed length", sym->name, &sym->declared_at);
}
}
static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
gfc_formal_arglist *f, *new_arglist;
gfc_symbol *new_sym;
for (; new_args != NULL; new_args = new_args->next)
{
new_sym = new_args->sym;
for (f = proc->formal; f; f = f->next)
{
if (new_sym == f->sym)
break;
}
if (f)
continue;
new_arglist = gfc_get_formal_arglist ();
new_arglist->sym = new_sym;
new_arglist->next = proc->formal;
proc->formal = new_arglist;
}
}
static void
check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
gfc_formal_arglist *f, *head;
head = new_args;
for (f = proc->formal; f; f = f->next)
{
if (f->sym == NULL)
continue;
for (new_args = head; new_args; new_args = new_args->next)
{
if (new_args->sym == f->sym)
break;
}
if (new_args)
continue;
f->sym->attr.not_always_present = 1;
}
}
static void
resolve_entries (gfc_namespace * ns)
{
gfc_namespace *old_ns;
gfc_code *c;
gfc_symbol *proc;
gfc_entry_list *el;
char name[GFC_MAX_SYMBOL_LEN + 1];
static int master_count = 0;
if (ns->proc_name == NULL)
return;
if (!ns->entries)
return;
if (ns->proc_name->attr.entry_master)
return;
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
old_ns = gfc_current_ns;
gfc_current_ns = ns;
el = gfc_get_entry_list ();
el->sym = ns->proc_name;
el->id = 0;
el->next = ns->entries;
ns->entries = el;
ns->proc_name->attr.entry = 1;
if (ns->proc_name->attr.function
&& ns->parent
&& ns->parent->proc_name->attr.flavor == FL_MODULE)
el->sym->ns = ns;
c = gfc_get_code ();
c->op = EXEC_ENTRY;
c->ext.entry = el;
c->next = ns->code;
ns->code = c;
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
master_count++, ns->proc_name->name);
gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL);
gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
if (ns->proc_name->attr.subroutine)
gfc_add_subroutine (&proc->attr, proc->name, NULL);
else
{
gfc_symbol *sym;
gfc_typespec *ts, *fts;
gfc_array_spec *as, *fas;
gfc_add_function (&proc->attr, proc->name, NULL);
proc->result = proc;
fas = ns->entries->sym->as;
fas = fas ? fas : ns->entries->sym->result->as;
fts = &ns->entries->sym->result->ts;
if (fts->type == BT_UNKNOWN)
fts = gfc_get_default_type (ns->entries->sym->result, NULL);
for (el = ns->entries->next; el; el = el->next)
{
ts = &el->sym->result->ts;
as = el->sym->as;
as = as ? as : el->sym->result->as;
if (ts->type == BT_UNKNOWN)
ts = gfc_get_default_type (el->sym->result, NULL);
if (! gfc_compare_types (ts, fts)
|| (el->sym->result->attr.dimension
!= ns->entries->sym->result->attr.dimension)
|| (el->sym->result->attr.pointer
!= ns->entries->sym->result->attr.pointer))
break;
else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
gfc_error ("Procedure %s at %L has entries with mismatched "
"array specifications", ns->entries->sym->name,
&ns->entries->sym->declared_at);
}
if (el == NULL)
{
sym = ns->entries->sym->result;
proc->ts = *fts;
if (sym->attr.dimension)
gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
if (sym->attr.pointer)
gfc_add_pointer (&proc->attr, NULL);
}
else
{
proc->attr.mixed_entry_master = 1;
for (el = ns->entries; el; el = el->next)
{
sym = el->sym->result;
if (sym->attr.dimension)
{
if (el == ns->entries)
gfc_error
("FUNCTION result %s can't be an array in FUNCTION %s at %L",
sym->name, ns->entries->sym->name, &sym->declared_at);
else
gfc_error
("ENTRY result %s can't be an array in FUNCTION %s at %L",
sym->name, ns->entries->sym->name, &sym->declared_at);
}
else if (sym->attr.pointer)
{
if (el == ns->entries)
gfc_error
("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
sym->name, ns->entries->sym->name, &sym->declared_at);
else
gfc_error
("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
sym->name, ns->entries->sym->name, &sym->declared_at);
}
else
{
ts = &sym->ts;
if (ts->type == BT_UNKNOWN)
ts = gfc_get_default_type (sym, NULL);
switch (ts->type)
{
case BT_INTEGER:
if (ts->kind == gfc_default_integer_kind)
sym = NULL;
break;
case BT_REAL:
if (ts->kind == gfc_default_real_kind
|| ts->kind == gfc_default_double_kind)
sym = NULL;
break;
case BT_COMPLEX:
if (ts->kind == gfc_default_complex_kind)
sym = NULL;
break;
case BT_LOGICAL:
if (ts->kind == gfc_default_logical_kind)
sym = NULL;
break;
case BT_UNKNOWN:
sym = NULL;
break;
default:
break;
}
if (sym)
{
if (el == ns->entries)
gfc_error
("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
sym->name, gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
else
gfc_error
("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
sym->name, gfc_typename (ts), ns->entries->sym->name,
&sym->declared_at);
}
}
}
}
}
proc->attr.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1;
for (el = ns->entries; el; el = el->next)
merge_argument_lists (proc, el->sym->formal);
for (el = ns->entries; el; el = el->next)
check_argument_lists (proc, el->sym->formal);
ns->proc_name = proc;
gfc_commit_symbols ();
gfc_current_ns = old_ns;
}
static void
resolve_contained_functions (gfc_namespace * ns)
{
gfc_namespace *child;
gfc_entry_list *el;
resolve_formal_arglists (ns);
for (child = ns->contained; child; child = child->sibling)
{
resolve_entries (child);
resolve_contained_fntype (child->proc_name, child);
for (el = child->entries; el; el = el->next)
resolve_contained_fntype (el->sym, child);
}
}
static try
resolve_structure_cons (gfc_expr * expr)
{
gfc_constructor *cons;
gfc_component *comp;
try t;
symbol_attribute a;
t = SUCCESS;
cons = expr->value.constructor;
if (expr->ref)
comp = expr->ref->u.c.sym->components;
else
comp = expr->ts.derived->components;
for (; comp; comp = comp->next, cons = cons->next)
{
if (! cons->expr)
continue;
if (gfc_resolve_expr (cons->expr) == FAILURE)
{
t = FAILURE;
continue;
}
if (cons->expr->expr_type != EXPR_NULL
&& comp->as && comp->as->rank != cons->expr->rank
&& (comp->allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
"component (%d/%d)", &cons->expr->where,
cons->expr->rank, comp->as ? comp->as->rank : 0);
t = FAILURE;
}
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
gfc_basic_typename (cons->expr->ts.type),
gfc_basic_typename (comp->ts.type));
else
t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
if (!a.pointer && !a.target)
{
t = FAILURE;
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s' should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
}
return t;
}
static int
was_declared (gfc_symbol * sym)
{
symbol_attribute a;
a = sym->attr;
if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
return 0;
}
static int
generic_sym (gfc_symbol * sym)
{
gfc_symbol *s;
if (sym->attr.generic ||
(sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
return 1;
if (was_declared (sym) || sym->ns->parent == NULL)
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
return (s == NULL) ? 0 : generic_sym (s);
}
static int
specific_sym (gfc_symbol * sym)
{
gfc_symbol *s;
if (sym->attr.if_source == IFSRC_IFBODY
|| sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_INTERNAL
|| sym->attr.proc == PROC_ST_FUNCTION
|| (sym->attr.intrinsic &&
gfc_specific_intrinsic (sym->name))
|| sym->attr.external)
return 1;
if (was_declared (sym) || sym->ns->parent == NULL)
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
return (s == NULL) ? 0 : specific_sym (s);
}
typedef enum
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
proc_type;
static proc_type
procedure_kind (gfc_symbol * sym)
{
if (generic_sym (sym))
return PTYPE_GENERIC;
if (specific_sym (sym))
return PTYPE_SPECIFIC;
return PTYPE_UNKNOWN;
}
static int need_full_assumed_size = 0;
static bool
check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
{
gfc_ref * ref;
int dim;
int last = 1;
if (need_full_assumed_size
|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
return false;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY)
for (dim = 0; dim < ref->u.ar.as->rank; dim++)
last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
if (last)
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
"array '%s' at %L.", sym->name, &e->where);
return true;
}
return false;
}
static bool
resolve_assumed_size_actual (gfc_expr *e)
{
if (e == NULL)
return false;
switch (e->expr_type)
{
case EXPR_VARIABLE:
if (e->symtree
&& check_assumed_size_reference (e->symtree->n.sym, e))
return true;
break;
case EXPR_OP:
if (resolve_assumed_size_actual (e->value.op.op1)
|| resolve_assumed_size_actual (e->value.op.op2))
return true;
break;
default:
break;
}
return false;
}
static try
resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
for (; arg; arg = arg->next)
{
e = arg->expr;
if (e == NULL)
{
if (arg->label)
{
if (arg->label->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
return FAILURE;
}
}
continue;
}
if (e->ts.type != BT_PROCEDURE)
{
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
goto argument_list;
}
sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE
|| sym->attr.intrinsic
|| sym->attr.external)
{
int actual_ok;
if (!sym->attr.intrinsic
&& !(sym->attr.external || sym->attr.use_assoc
|| sym->attr.if_source == IFSRC_IFBODY)
&& gfc_intrinsic_name (sym->name, sym->attr.subroutine))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Statement function '%s' at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine);
if (sym->attr.intrinsic && actual_ok == 0)
{
gfc_error ("Intrinsic '%s' at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
if (sym->attr.contained && !sym->attr.use_assoc
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
gfc_error ("Internal procedure '%s' is not allowed as an "
"actual argument at %L", sym->name, &e->where);
}
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
"allowed as an actual argument at %L", sym->name,
&e->where);
}
if (sym->attr.generic)
{
gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
"allowed as an actual argument at %L", sym->name,
&e->where);
}
if (sym->attr.function && sym->result == sym
&& (sym->ns->proc_name == sym
|| (sym->ns->parent != NULL
&& sym->ns->parent->proc_name == sym)))
goto got_variable;
if (sym->attr.function
&& sym->ts.type == BT_UNKNOWN
&& sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->name);
if (isym == NULL || !isym->specific)
{
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
}
sym->ts = isym->ts;
}
goto argument_list;
}
if (was_declared (sym) || sym->ns->parent == NULL)
goto got_variable;
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
return FAILURE;
}
if (parent_st == NULL)
goto got_variable;
sym = parent_st->n.sym;
e->symtree = parent_st;
if (sym->attr.flavor == FL_PROCEDURE
|| sym->attr.intrinsic
|| sym->attr.external)
{
goto argument_list;
}
got_variable:
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
if (sym->as != NULL)
{
e->rank = sym->as->rank;
e->ref = gfc_get_ref ();
e->ref->type = REF_ARRAY;
e->ref->u.ar.type = AR_FULL;
e->ref->u.ar.as = sym->as;
}
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
argument_list:
if (arg->name && arg->name[0] == '%')
{
if (strncmp ("%VAL", arg->name, 4) == 0)
{
if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
return FAILURE;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
return FAILURE;
}
if (ptype != PROC_UNKNOWN && ptype != PROC_EXTERNAL)
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
return FAILURE;
}
if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX)
&& e->ts.kind > gfc_default_real_kind)
|| (e->ts.kind > gfc_default_integer_kind))
{
gfc_error ("Kind of by-value argument at %L is larger "
"than default kind", &e->where);
return FAILURE;
}
}
else if (strncmp ("%LOC", arg->name, 4) == 0
&& e->ts.type == BT_PROCEDURE)
{
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
return FAILURE;
}
}
}
}
return SUCCESS;
}
static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
gfc_actual_arglist *arg0;
gfc_actual_arglist *arg;
gfc_symbol *esym = NULL;
gfc_intrinsic_sym *isym = NULL;
gfc_expr *e = NULL;
gfc_intrinsic_arg *iformal = NULL;
gfc_formal_arglist *eformal = NULL;
bool formal_optional = false;
bool set_by_optional = false;
int i;
int rank = 0;
if (expr && expr->value.function.actual != NULL)
{
if (expr->value.function.esym != NULL
&& expr->value.function.esym->attr.elemental)
{
arg0 = expr->value.function.actual;
esym = expr->value.function.esym;
}
else if (expr->value.function.isym != NULL
&& expr->value.function.isym->elemental)
{
arg0 = expr->value.function.actual;
isym = expr->value.function.isym;
}
else
return SUCCESS;
}
else if (c && c->ext.actual != NULL
&& c->symtree->n.sym->attr.elemental)
{
arg0 = c->ext.actual;
esym = c->symtree->n.sym;
}
else
return SUCCESS;
for (arg = arg0; arg; arg = arg->next)
{
if (arg->expr != NULL && arg->expr->rank > 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree->n.sym->attr.optional)
set_by_optional = true;
if (expr)
{
expr->rank = rank;
if (!expr->shape && arg->expr->shape)
{
expr->shape = gfc_get_shape (rank);
for (i = 0; i < rank; i++)
mpz_init_set (expr->shape[i], arg->expr->shape[i]);
}
}
break;
}
}
formal_optional = false;
if (isym)
iformal = isym->formal;
else
eformal = esym->formal;
for (arg = arg0; arg; arg = arg->next)
{
if (eformal)
{
if (eformal->sym && eformal->sym->attr.optional)
formal_optional = true;
eformal = eformal->next;
}
else if (isym && iformal)
{
if (iformal->optional)
formal_optional = true;
iformal = iformal->next;
}
else if (isym)
formal_optional = true;
if (pedantic && arg->expr != NULL
&& arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree->n.sym->attr.optional
&& formal_optional
&& arg->expr->rank
&& (set_by_optional || arg->expr->rank != rank)
&& !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
{
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
"MISSING, it cannot be the actual argument of an "
"ELEMENTAL procedure unless there is a non-optional"
"argument with the same rank (12.4.1.5)",
arg->expr->symtree->n.sym->name, &arg->expr->where);
return FAILURE;
}
}
for (arg = arg0; arg; arg = arg->next)
{
if (arg->expr == NULL || arg->expr->rank == 0)
continue;
if (resolve_assumed_size_actual (arg->expr))
return FAILURE;
if (expr)
continue;
if (e != NULL)
{
if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
== FAILURE)
return FAILURE;
}
else
e = arg->expr;
}
return SUCCESS;
}
static void
find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
{
gfc_actual_arglist *ap;
gfc_expr *expr;
for (ap = actual; ap; ap = ap->next)
if (ap->expr
&& (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
&& !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
ap->expr->inline_noncopying_intrinsic = 1;
}
static void
resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
{
gfc_gsymbol * gsym;
unsigned int type;
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
gsym = gfc_get_gsymbol (sym->name);
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
global_used (gsym, where);
if (gsym->type == GSYM_UNKNOWN)
{
gsym->type = type;
gsym->where = *where;
}
gsym->used = 1;
}
static match
resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
{
gfc_symbol *s;
if (sym->attr.generic)
{
s =
gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
if (s != NULL)
{
expr->value.function.name = s->name;
expr->value.function.esym = s;
if (s->ts.type != BT_UNKNOWN)
expr->ts = s->ts;
else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
expr->ts = s->result->ts;
if (s->as != NULL)
expr->rank = s->as->rank;
else if (s->result != NULL && s->result->as != NULL)
expr->rank = s->result->as->rank;
return MATCH_YES;
}
}
if (sym->attr.intrinsic)
return gfc_intrinsic_func_interface (expr, 0);
return MATCH_NO;
}
static try
resolve_generic_f (gfc_expr * expr)
{
gfc_symbol *sym;
match m;
sym = expr->symtree->n.sym;
for (;;)
{
m = resolve_generic_f0 (expr, sym);
if (m == MATCH_YES)
return SUCCESS;
else if (m == MATCH_ERROR)
return FAILURE;
generic:
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym == NULL)
break;
if (!generic_sym (sym))
goto generic;
}
if (sym && !gfc_intrinsic_name (sym->name, 0))
{
gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_NO)
gfc_error
("Generic function '%s' at %L is not consistent with a specific "
"intrinsic interface", expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
static match
resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
{
match m;
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
{
sym->attr.proc = PROC_DUMMY;
goto found;
}
sym->attr.proc = PROC_EXTERNAL;
goto found;
}
if (sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_ST_FUNCTION
|| sym->attr.proc == PROC_INTERNAL)
goto found;
if (sym->attr.intrinsic)
{
m = gfc_intrinsic_func_interface (expr, 1);
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
gfc_error
("Function '%s' at %L is INTRINSIC but is not compatible with "
"an intrinsic", sym->name, &expr->where);
return MATCH_ERROR;
}
return MATCH_NO;
found:
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
expr->ts = sym->ts;
expr->value.function.name = sym->name;
expr->value.function.esym = sym;
if (sym->as != NULL)
expr->rank = sym->as->rank;
return MATCH_YES;
}
static try
resolve_specific_f (gfc_expr * expr)
{
gfc_symbol *sym;
match m;
sym = expr->symtree->n.sym;
for (;;)
{
m = resolve_specific_f0 (sym, expr);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_ERROR)
return FAILURE;
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym == NULL)
break;
}
gfc_error ("Unable to resolve the specific function '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
return SUCCESS;
}
static try
resolve_unknown_f (gfc_expr * expr)
{
gfc_symbol *sym;
gfc_typespec *ts;
sym = expr->symtree->n.sym;
if (sym->attr.dummy)
{
sym->attr.proc = PROC_DUMMY;
expr->value.function.name = sym->name;
goto set_type;
}
if (gfc_intrinsic_name (sym->name, 0))
{
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
return SUCCESS;
return FAILURE;
}
sym->attr.proc = PROC_EXTERNAL;
expr->value.function.name = sym->name;
expr->value.function.esym = expr->symtree->n.sym;
if (sym->as != NULL)
expr->rank = sym->as->rank;
set_type:
gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
if (sym->ts.type != BT_UNKNOWN)
expr->ts = sym->ts;
else
{
ts = gfc_get_default_type (sym, sym->ns);
if (ts->type == BT_UNKNOWN)
{
gfc_error ("Function '%s' at %L has no IMPLICIT type",
sym->name, &expr->where);
return FAILURE;
}
else
expr->ts = *ts;
}
return SUCCESS;
}
static int
pure_function (gfc_expr * e, const char **name)
{
int pure;
*name = NULL;
if (e->symtree != NULL
&& e->symtree->n.sym != NULL
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
{
*name = e->symtree->n.sym->name;
return 1;
}
if (e->value.function.esym)
{
pure = gfc_pure (e->value.function.esym);
*name = e->value.function.esym->name;
}
else if (e->value.function.isym)
{
pure = e->value.function.isym->pure
|| e->value.function.isym->elemental;
*name = e->value.function.isym->name;
}
else
{
pure = 0;
*name = e->value.function.name;
}
return pure;
}
static try
resolve_function (gfc_expr * expr)
{
gfc_actual_arglist *arg;
gfc_symbol * sym;
const char *name;
try t;
int temp;
procedure_type p = PROC_INTRINSIC;
sym = NULL;
if (expr->symtree)
sym = expr->symtree->n.sym;
if (sym && sym->attr.flavor == FL_VARIABLE)
{
gfc_error ("'%s' at %L is not a function",
sym->name, &expr->where);
return FAILURE;
}
if (sym && !sym->attr.dummy && !sym->attr.contained
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.use_assoc)
resolve_global_procedure (sym, &expr->where, 0);
need_full_assumed_size++;
if (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
return FAILURE;
need_full_assumed_size--;
if (sym && sym->ts.type == BT_CHARACTER
&& sym->ts.cl
&& sym->ts.cl->length == NULL
&& !sym->attr.dummy
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
{
gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
"be used at %L since it is not a dummy argument",
sym->name, &expr->where);
return FAILURE;
}
if (expr->value.function.name != NULL)
{
if (expr->ts.type == BT_UNKNOWN)
expr->ts = sym->ts;
t = SUCCESS;
}
else
{
switch (procedure_kind (sym))
{
case PTYPE_GENERIC:
t = resolve_generic_f (expr);
break;
case PTYPE_SPECIFIC:
t = resolve_specific_f (expr);
break;
case PTYPE_UNKNOWN:
t = resolve_unknown_f (expr);
break;
default:
gfc_internal_error ("resolve_function(): bad function type");
}
}
if (expr->expr_type != EXPR_FUNCTION)
return t;
temp = need_full_assumed_size;
need_full_assumed_size = 0;
if (resolve_elemental_actual (expr, NULL) == FAILURE)
return FAILURE;
if (omp_workshare_flag
&& expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym))
{
gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
" in WORKSHARE construct", expr->value.function.esym->name,
&expr->where);
t = FAILURE;
}
#define GENERIC_ID expr->value.function.isym->generic_id
else if (expr->value.function.actual != NULL
&& expr->value.function.isym != NULL
&& GENERIC_ID != GFC_ISYM_LBOUND
&& GENERIC_ID != GFC_ISYM_LEN
&& GENERIC_ID != GFC_ISYM_LOC
&& GENERIC_ID != GFC_ISYM_PRESENT)
{
int inquiry;
inquiry = GENERIC_ID == GFC_ISYM_UBOUND
|| GENERIC_ID == GFC_ISYM_SIZE;
for (arg = expr->value.function.actual; arg; arg = arg->next)
{
if (inquiry && arg->next != NULL && arg->next->expr)
{
if (arg->next->expr->expr_type != EXPR_CONSTANT)
break;
if ((int)mpz_get_si (arg->next->expr->value.integer)
< arg->expr->rank)
break;
}
if (arg->expr != NULL
&& arg->expr->rank > 0
&& resolve_assumed_size_actual (arg->expr))
return FAILURE;
}
}
#undef GENERIC_ID
need_full_assumed_size = temp;
name = NULL;
if (!pure_function (expr, &name) && name)
{
if (forall_flag)
{
gfc_error
("reference to non-PURE function '%s' at %L inside a "
"FORALL %s", name, &expr->where, forall_flag == 2 ?
"mask" : "block");
t = FAILURE;
}
else if (gfc_pure (NULL))
{
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
"procedure within a PURE procedure", name, &expr->where);
t = FAILURE;
}
}
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
{
gfc_symbol *esym, *proc;
esym = expr->value.function.esym;
proc = gfc_current_ns->proc_name;
if (esym == proc)
{
gfc_error ("Function '%s' at %L cannot call itself, as it is not "
"RECURSIVE", name, &expr->where);
t = FAILURE;
}
if (esym->attr.entry && esym->ns->entries && proc->ns->entries
&& esym->ns->entries->sym == proc->ns->entries->sym)
{
gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
"'%s' is not declared as RECURSIVE",
esym->name, &expr->where, esym->ns->entries->sym->name);
t = FAILURE;
}
}
if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
&& expr->value.function.esym->attr.use_assoc)
{
gfc_expr_set_symbols_referenced (expr->ts.cl->length);
}
if (t == SUCCESS)
find_noncopying_intrinsics (expr->value.function.esym,
expr->value.function.actual);
if (expr->ts.type == BT_UNKNOWN)
{
if (expr->symtree->n.sym->result
&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
expr->ts = expr->symtree->n.sym->result->ts;
else
expr->ts = expr->symtree->n.sym->result->ts;
}
return t;
}
static void
pure_subroutine (gfc_code * c, gfc_symbol * sym)
{
if (gfc_pure (sym))
return;
if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
sym->name, &c->loc);
else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc);
}
static match
resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
{
gfc_symbol *s;
if (sym->attr.generic)
{
s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
if (s != NULL)
{
c->resolved_sym = s;
pure_subroutine (c, s);
return MATCH_YES;
}
}
if (sym->attr.intrinsic)
return gfc_intrinsic_sub_interface (c, 0);
return MATCH_NO;
}
static try
resolve_generic_s (gfc_code * c)
{
gfc_symbol *sym;
match m;
sym = c->symtree->n.sym;
for (;;)
{
m = resolve_generic_s0 (c, sym);
if (m == MATCH_YES)
return SUCCESS;
else if (m == MATCH_ERROR)
return FAILURE;
generic:
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym == NULL)
break;
if (!generic_sym (sym))
goto generic;
}
sym = c->symtree->n.sym;
if (!gfc_intrinsic_name (sym->name, 1))
{
gfc_error
("There is no specific subroutine for the generic '%s' at %L",
sym->name, &c->loc);
return FAILURE;
}
m = gfc_intrinsic_sub_interface (c, 0);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_NO)
gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
"intrinsic subroutine interface", sym->name, &c->loc);
return FAILURE;
}
static match
resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
{
match m;
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
{
sym->attr.proc = PROC_DUMMY;
goto found;
}
sym->attr.proc = PROC_EXTERNAL;
goto found;
}
if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
goto found;
if (sym->attr.intrinsic)
{
m = gfc_intrinsic_sub_interface (c, 1);
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
"with an intrinsic", sym->name, &c->loc);
return MATCH_ERROR;
}
return MATCH_NO;
found:
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
c->resolved_sym = sym;
pure_subroutine (c, sym);
return MATCH_YES;
}
static try
resolve_specific_s (gfc_code * c)
{
gfc_symbol *sym;
match m;
sym = c->symtree->n.sym;
for (;;)
{
m = resolve_specific_s0 (c, sym);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_ERROR)
return FAILURE;
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym == NULL)
break;
}
sym = c->symtree->n.sym;
gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
sym->name, &c->loc);
return FAILURE;
}
static try
resolve_unknown_s (gfc_code * c)
{
gfc_symbol *sym;
sym = c->symtree->n.sym;
if (sym->attr.dummy)
{
sym->attr.proc = PROC_DUMMY;
goto found;
}
if (gfc_intrinsic_name (sym->name, 1))
{
if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
return SUCCESS;
return FAILURE;
}
found:
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
c->resolved_sym = sym;
pure_subroutine (c, sym);
return SUCCESS;
}
static try
resolve_call (gfc_code * c)
{
try t;
procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
"the CALL at %L", c->symtree->n.sym->name,
&c->symtree->n.sym->declared_at, &c->loc);
return FAILURE;
}
if (c->symtree && c->symtree->n.sym
&& !c->symtree->n.sym->attr.dummy
&& !c->symtree->n.sym->attr.contained
&& !c->symtree->n.sym->attr.use_assoc)
resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
{
gfc_symbol *csym, *proc;
csym = c->symtree->n.sym;
proc = gfc_current_ns->proc_name;
if (csym == proc)
{
gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
"RECURSIVE", csym->name, &c->loc);
t = FAILURE;
}
if (csym->attr.entry && csym->ns->entries && proc->ns->entries
&& csym->ns->entries->sym == proc->ns->entries->sym)
{
gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
"'%s' is not declared as RECURSIVE",
csym->name, &c->loc, csym->ns->entries->sym->name);
t = FAILURE;
}
}
need_full_assumed_size++;
if (c->symtree && c->symtree->n.sym)
ptype = c->symtree->n.sym->attr.proc;
if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
return FAILURE;
need_full_assumed_size--;
t = SUCCESS;
if (c->resolved_sym == NULL)
switch (procedure_kind (c->symtree->n.sym))
{
case PTYPE_GENERIC:
t = resolve_generic_s (c);
break;
case PTYPE_SPECIFIC:
t = resolve_specific_s (c);
break;
case PTYPE_UNKNOWN:
t = resolve_unknown_s (c);
break;
default:
gfc_internal_error ("resolve_subroutine(): bad function type");
}
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
if (t == SUCCESS)
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
static try
compare_shapes (gfc_expr * op1, gfc_expr * op2)
{
try t;
int i;
t = SUCCESS;
if (op1->shape != NULL && op2->shape != NULL)
{
for (i = 0; i < op1->rank; i++)
{
if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
{
gfc_error ("Shapes for operands at %L and %L are not conformable",
&op1->where, &op2->where);
t = FAILURE;
break;
}
}
}
return t;
}
static try
resolve_operator (gfc_expr * e)
{
gfc_expr *op1, *op2;
char msg[200];
try t;
switch (e->value.op.operator)
{
default:
if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
return FAILURE;
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
case INTRINSIC_PARENTHESES:
if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
}
op1 = e->value.op.op1;
op2 = e->value.op.op2;
switch (e->value.op.operator)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
if (op1->ts.type == BT_INTEGER
|| op1->ts.type == BT_REAL
|| op1->ts.type == BT_COMPLEX)
{
e->ts = op1->ts;
break;
}
sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
goto bad_op;
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
case INTRINSIC_POWER:
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
gfc_type_convert_binary (e);
break;
}
sprintf (msg,
_("Operands of binary numeric operator '%s' at %%L are %s/%s"),
gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_CONCAT:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
e->ts.type = BT_CHARACTER;
e->ts.kind = op1->ts.kind;
break;
}
sprintf (msg,
_("Operands of string concatenation operator at %%L are %s/%s"),
gfc_typename (&op1->ts), gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_AND:
case INTRINSIC_OR:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_kind_max (op1, op2);
if (op1->ts.kind < e->ts.kind)
gfc_convert_type (op1, &e->ts, 2);
else if (op2->ts.kind < e->ts.kind)
gfc_convert_type (op2, &e->ts, 2);
break;
}
sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_NOT:
if (op1->ts.type == BT_LOGICAL)
{
e->ts.type = BT_LOGICAL;
e->ts.kind = op1->ts.kind;
break;
}
sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
gfc_typename (&op1->ts));
goto bad_op;
case INTRINSIC_GT:
case INTRINSIC_GE:
case INTRINSIC_LT:
case INTRINSIC_LE:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
goto bad_op;
}
case INTRINSIC_EQ:
case INTRINSIC_NE:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
break;
}
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
gfc_type_convert_binary (e);
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
break;
}
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
_("Logicals at %%L must be compared with %s instead of %s"),
e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
gfc_op2string (e->value.op.operator));
else
sprintf (msg,
_("Operands of comparison operator '%s' at %%L are %s/%s"),
gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
else
sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
e->value.op.uop->name, gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_PARENTHESES:
break;
default:
gfc_internal_error ("resolve_operator(): Bad intrinsic");
}
t = SUCCESS;
switch (e->value.op.operator)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
case INTRINSIC_POWER:
case INTRINSIC_CONCAT:
case INTRINSIC_AND:
case INTRINSIC_OR:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
case INTRINSIC_NE:
case INTRINSIC_GT:
case INTRINSIC_GE:
case INTRINSIC_LT:
case INTRINSIC_LE:
if (op1->rank == 0 && op2->rank == 0)
e->rank = 0;
if (op1->rank == 0 && op2->rank != 0)
{
e->rank = op2->rank;
if (e->shape == NULL)
e->shape = gfc_copy_shape (op2->shape, op2->rank);
}
if (op1->rank != 0 && op2->rank == 0)
{
e->rank = op1->rank;
if (e->shape == NULL)
e->shape = gfc_copy_shape (op1->shape, op1->rank);
}
if (op1->rank != 0 && op2->rank != 0)
{
if (op1->rank == op2->rank)
{
e->rank = op1->rank;
if (e->shape == NULL)
{
t = compare_shapes(op1, op2);
if (t == FAILURE)
e->shape = NULL;
else
e->shape = gfc_copy_shape (op1->shape, op1->rank);
}
}
else
{
gfc_error ("Inconsistent ranks for operator at %L and %L",
&op1->where, &op2->where);
t = FAILURE;
e->rank = 0;
}
}
break;
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
case INTRINSIC_PARENTHESES:
e->rank = op1->rank;
if (e->shape == NULL)
e->shape = gfc_copy_shape (op1->shape, op1->rank);
break;
default:
break;
}
if (t == SUCCESS)
{
t = gfc_simplify_expr (e, 0);
if (!gfc_is_constant_expr (e))
t = SUCCESS;
}
return t;
bad_op:
if (gfc_extend_expr (e) == SUCCESS)
return SUCCESS;
gfc_error (msg, &e->where);
return FAILURE;
}
typedef enum
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
comparison;
static comparison
compare_bound (gfc_expr * a, gfc_expr * b)
{
int i;
if (a == NULL || a->expr_type != EXPR_CONSTANT
|| b == NULL || b->expr_type != EXPR_CONSTANT)
return CMP_UNKNOWN;
if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
gfc_internal_error ("compare_bound(): Bad expression");
i = mpz_cmp (a->value.integer, b->value.integer);
if (i < 0)
return CMP_LT;
if (i > 0)
return CMP_GT;
return CMP_EQ;
}
static comparison
compare_bound_int (gfc_expr * a, int b)
{
int i;
if (a == NULL || a->expr_type != EXPR_CONSTANT)
return CMP_UNKNOWN;
if (a->ts.type != BT_INTEGER)
gfc_internal_error ("compare_bound_int(): Bad expression");
i = mpz_cmp_si (a->value.integer, b);
if (i < 0)
return CMP_LT;
if (i > 0)
return CMP_GT;
return CMP_EQ;
}
static comparison
compare_bound_mpz_t (gfc_expr * a, mpz_t b)
{
int i;
if (a == NULL || a->expr_type != EXPR_CONSTANT)
return CMP_UNKNOWN;
if (a->ts.type != BT_INTEGER)
gfc_internal_error ("compare_bound_int(): Bad expression");
i = mpz_cmp (a->value.integer, b);
if (i < 0)
return CMP_LT;
if (i > 0)
return CMP_GT;
return CMP_EQ;
}
static int
compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
gfc_expr * stride, mpz_t last)
{
mpz_t rem;
if (start == NULL || start->expr_type != EXPR_CONSTANT
|| end == NULL || end->expr_type != EXPR_CONSTANT
|| (stride != NULL && stride->expr_type != EXPR_CONSTANT))
return 0;
if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
|| (stride != NULL && stride->ts.type != BT_INTEGER))
return 0;
if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
{
if (compare_bound (start, end) == CMP_GT)
return 0;
mpz_set (last, end->value.integer);
return 1;
}
if (compare_bound_int (stride, 0) == CMP_GT)
{
if (mpz_cmp (start->value.integer, end->value.integer) > 0)
return 0;
}
else
{
if (mpz_cmp (start->value.integer, end->value.integer) < 0)
return 0;
}
mpz_init (rem);
mpz_sub (rem, end->value.integer, start->value.integer);
mpz_tdiv_r (rem, rem, stride->value.integer);
mpz_sub (last, end->value.integer, rem);
mpz_clear (rem);
return 1;
}
static try
check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
{
mpz_t last_value;
switch (ar->type)
{
case AR_FULL:
break;
case AR_ELEMENT:
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
goto bound;
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
goto bound;
break;
case AR_SECTION:
if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
{
gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
return FAILURE;
}
#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
if (compare_bound (AR_START, AR_END) == CMP_EQ
&& (compare_bound (AR_START, as->lower[i]) == CMP_LT
|| compare_bound (AR_START, as->upper[i]) == CMP_GT))
goto bound;
if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
|| ar->stride[i] == NULL)
&& compare_bound (AR_START, AR_END) != CMP_GT)
|| (compare_bound_int (ar->stride[i], 0) == CMP_LT
&& compare_bound (AR_START, AR_END) != CMP_LT))
{
if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
goto bound;
if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
goto bound;
}
mpz_init (last_value);
if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
last_value))
{
if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
|| compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
{
mpz_clear (last_value);
goto bound;
}
}
mpz_clear (last_value);
#undef AR_START
#undef AR_END
break;
default:
gfc_internal_error ("check_dimension(): Bad array reference");
}
return SUCCESS;
bound:
gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
return SUCCESS;
}
static try
compare_spec_to_ref (gfc_array_ref * ar)
{
gfc_array_spec *as;
int i;
as = ar->as;
i = as->rank - 1;
if (as->type == AS_ASSUMED_SIZE
&& ( (ar->type == AR_SECTION
&& ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
{
gfc_error ("Rightmost upper bound of assumed size array section"
" not specified at %L", &ar->where);
return FAILURE;
}
if (ar->type == AR_FULL)
return SUCCESS;
if (as->rank != ar->dimen)
{
gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
&ar->where, ar->dimen, as->rank);
return FAILURE;
}
for (i = 0; i < as->rank; i++)
if (check_dimension (i, ar, as) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_resolve_index (gfc_expr * index, int check_scalar)
{
gfc_typespec ts;
if (index == NULL)
return SUCCESS;
if (gfc_resolve_expr (index) == FAILURE)
return FAILURE;
if (check_scalar && index->rank != 0)
{
gfc_error ("Array index at %L must be scalar", &index->where);
return FAILURE;
}
if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
{
gfc_error ("Array index at %L must be of INTEGER type",
&index->where);
return FAILURE;
}
if (index->ts.type == BT_REAL)
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
&index->where) == FAILURE)
return FAILURE;
if (index->ts.kind != gfc_index_integer_kind
|| index->ts.type != BT_INTEGER)
{
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
gfc_convert_type_warn (index, &ts, 2, 0);
}
return SUCCESS;
}
try
gfc_resolve_dim_arg (gfc_expr *dim)
{
if (dim == NULL)
return SUCCESS;
if (gfc_resolve_expr (dim) == FAILURE)
return FAILURE;
if (dim->rank != 0)
{
gfc_error ("Argument dim at %L must be scalar", &dim->where);
return FAILURE;
}
if (dim->ts.type != BT_INTEGER)
{
gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
return FAILURE;
}
if (dim->ts.kind != gfc_index_integer_kind)
{
gfc_typespec ts;
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
gfc_convert_type_warn (dim, &ts, 2, 0);
}
return SUCCESS;
}
static void
find_array_spec (gfc_expr * e)
{
gfc_array_spec *as;
gfc_component *c;
gfc_symbol *derived;
gfc_ref *ref;
as = e->symtree->n.sym->as;
derived = NULL;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
if (as == NULL)
gfc_internal_error ("find_array_spec(): Missing spec");
ref->u.ar.as = as;
as = NULL;
break;
case REF_COMPONENT:
if (derived == NULL)
derived = e->symtree->n.sym->ts.derived;
c = derived->components;
for (; c; c = c->next)
if (c == ref->u.c.component)
{
if (c->ts.type == BT_DERIVED)
derived = c->ts.derived;
break;
}
if (c == NULL)
gfc_internal_error ("find_array_spec(): Component not found");
if (c->dimension)
{
if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
as = c->as;
}
break;
case REF_SUBSTRING:
break;
}
if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(2)");
}
static try
resolve_array_ref (gfc_array_ref * ar)
{
int i, check_scalar;
gfc_expr *e;
for (i = 0; i < ar->dimen; i++)
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
return FAILURE;
if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
return FAILURE;
if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
return FAILURE;
e = ar->start[i];
if (ar->dimen_type[i] == DIMEN_UNKNOWN)
switch (e->rank)
{
case 0:
ar->dimen_type[i] = DIMEN_ELEMENT;
break;
case 1:
ar->dimen_type[i] = DIMEN_VECTOR;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->ts.type == BT_DERIVED)
ar->start[i] = gfc_get_parentheses (e);
break;
default:
gfc_error ("Array index at %L is an array of rank %d",
&ar->c_where[i], e->rank);
return FAILURE;
}
}
if (ar->type == AR_UNKNOWN)
{
ar->type = AR_ELEMENT;
for (i = 0; i < ar->dimen; i++)
if (ar->dimen_type[i] == DIMEN_RANGE
|| ar->dimen_type[i] == DIMEN_VECTOR)
{
ar->type = AR_SECTION;
break;
}
}
if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
return SUCCESS;
}
static try
resolve_substring (gfc_ref * ref)
{
if (ref->u.ss.start != NULL)
{
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
return FAILURE;
if (ref->u.ss.start->ts.type != BT_INTEGER)
{
gfc_error ("Substring start index at %L must be of type INTEGER",
&ref->u.ss.start->where);
return FAILURE;
}
if (ref->u.ss.start->rank != 0)
{
gfc_error ("Substring start index at %L must be scalar",
&ref->u.ss.start->where);
return FAILURE;
}
if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
{
gfc_error ("Substring start index at %L is less than one",
&ref->u.ss.start->where);
return FAILURE;
}
}
if (ref->u.ss.end != NULL)
{
if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
return FAILURE;
if (ref->u.ss.end->ts.type != BT_INTEGER)
{
gfc_error ("Substring end index at %L must be of type INTEGER",
&ref->u.ss.end->where);
return FAILURE;
}
if (ref->u.ss.end->rank != 0)
{
gfc_error ("Substring end index at %L must be scalar",
&ref->u.ss.end->where);
return FAILURE;
}
if (ref->u.ss.length != NULL
&& compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
&& (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
|| compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
{
gfc_error ("Substring end index at %L exceeds the string length",
&ref->u.ss.start->where);
return FAILURE;
}
}
return SUCCESS;
}
static try
resolve_ref (gfc_expr * expr)
{
int current_part_dimension, n_components, seen_part_dimension;
gfc_ref *ref;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
{
find_array_spec (expr);
break;
}
for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
if (resolve_array_ref (&ref->u.ar) == FAILURE)
return FAILURE;
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
resolve_substring (ref);
break;
}
current_part_dimension = 0;
seen_part_dimension = 0;
n_components = 0;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
switch (ref->u.ar.type)
{
case AR_FULL:
case AR_SECTION:
current_part_dimension = 1;
break;
case AR_ELEMENT:
current_part_dimension = 0;
break;
case AR_UNKNOWN:
gfc_internal_error ("resolve_ref(): Bad array reference");
}
break;
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
if (ref->u.c.component->pointer)
{
gfc_error
("Component to the right of a part reference with nonzero "
"rank must not have the POINTER attribute at %L",
&expr->where);
return FAILURE;
}
else if (ref->u.c.component->allocatable)
{
gfc_error
("Component to the right of a part reference with nonzero "
"rank must not have the ALLOCATABLE attribute at %L",
&expr->where);
return FAILURE;
}
}
n_components++;
break;
case REF_SUBSTRING:
break;
}
if (((ref->type == REF_COMPONENT && n_components > 1)
|| ref->next == NULL)
&& current_part_dimension
&& seen_part_dimension)
{
gfc_error ("Two or more part references with nonzero rank must "
"not be specified at %L", &expr->where);
return FAILURE;
}
if (ref->type == REF_COMPONENT)
{
if (current_part_dimension)
seen_part_dimension = 1;
current_part_dimension = 0;
}
}
return SUCCESS;
}
static void
expression_shape (gfc_expr * e)
{
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
if (e->rank == 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
goto fail;
e->shape = gfc_get_shape (e->rank);
memcpy (e->shape, array, e->rank * sizeof (mpz_t));
return;
fail:
for (i--; i >= 0; i--)
mpz_clear (array[i]);
}
static void
expression_rank (gfc_expr * e)
{
gfc_ref *ref;
int i, rank;
if (e->ref == NULL)
{
if (e->expr_type == EXPR_ARRAY)
goto done;
if (e->symtree == NULL)
{
e->rank = 0;
goto done;
}
e->rank = (e->symtree->n.sym->as == NULL)
? 0 : e->symtree->n.sym->as->rank;
goto done;
}
rank = 0;
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type != REF_ARRAY)
continue;
if (ref->u.ar.type == AR_FULL)
{
rank = ref->u.ar.as->rank;
break;
}
if (ref->u.ar.type == AR_SECTION)
{
if (rank != 0)
gfc_internal_error ("expression_rank(): Two array specs");
for (i = 0; i < ref->u.ar.dimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
|| ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
rank++;
break;
}
}
e->rank = rank;
done:
expression_shape (e);
}
static try
resolve_variable (gfc_expr * e)
{
gfc_symbol *sym;
try t;
t = SUCCESS;
if (e->symtree == NULL)
return FAILURE;
if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE;
sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
{
e->ts.type = BT_PROCEDURE;
return SUCCESS;
}
if (sym->ts.type != BT_UNKNOWN)
gfc_variable_attr (e, &e->ts);
else
{
if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
return FAILURE;
e->ts = sym->ts;
}
if (check_assumed_size_reference (sym, e))
return FAILURE;
if (gfc_current_ns->entries
&& current_entry_id == sym->entry_id
&& cs_base
&& cs_base->current
&& cs_base->current->op != EXEC_ENTRY)
{
gfc_entry_list *entry;
gfc_formal_arglist *formal;
int n;
bool seen;
if (sym->attr.dummy)
{
entry = gfc_current_ns->entries;
seen = false;
for (; entry && entry->id <= current_entry_id; entry = entry->next)
for (formal = entry->sym->formal; formal; formal = formal->next)
{
if (formal->sym && sym->name == formal->sym->name)
seen = true;
}
if (!seen)
{
if (specification_expr)
gfc_error ("Variable '%s',used in a specification expression, "
"is referenced at %L before the ENTRY statement "
"in which it is a parameter",
sym->name, &cs_base->current->loc);
else
gfc_error ("Variable '%s' is used at %L before the ENTRY "
"statement in which it is a parameter",
sym->name, &cs_base->current->loc);
t = FAILURE;
}
}
specification_expr = 1;
if (sym->ts.type == BT_CHARACTER
&& gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
t = FAILURE;
if (sym->as)
for (n = 0; n < sym->as->rank; n++)
{
specification_expr = 1;
if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
t = FAILURE;
specification_expr = 1;
if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
t = FAILURE;
}
specification_expr = 0;
if (t == SUCCESS)
sym->entry_id = current_entry_id + 1;
}
return t;
}
try
gfc_resolve_expr (gfc_expr * e)
{
try t;
if (e == NULL)
return SUCCESS;
switch (e->expr_type)
{
case EXPR_OP:
t = resolve_operator (e);
break;
case EXPR_FUNCTION:
t = resolve_function (e);
break;
case EXPR_VARIABLE:
t = resolve_variable (e);
if (t == SUCCESS)
expression_rank (e);
break;
case EXPR_SUBSTRING:
t = resolve_ref (e);
break;
case EXPR_CONSTANT:
case EXPR_NULL:
t = SUCCESS;
break;
case EXPR_ARRAY:
t = FAILURE;
if (resolve_ref (e) == FAILURE)
break;
t = gfc_resolve_array_constructor (e);
if (t == SUCCESS)
{
expression_rank (e);
gfc_expand_constructor (e);
}
if (e->ts.type == BT_CHARACTER)
gfc_resolve_character_array_constructor (e);
break;
case EXPR_STRUCTURE:
t = resolve_ref (e);
if (t == FAILURE)
break;
t = resolve_structure_cons (e);
if (t == FAILURE)
break;
t = gfc_simplify_expr (e, 0);
break;
default:
gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
}
return t;
}
static try
gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
const char * name_msgid)
{
if (gfc_resolve_expr (expr) == FAILURE)
return FAILURE;
if (expr->rank != 0)
{
gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
return FAILURE;
}
if (!(expr->ts.type == BT_INTEGER
|| (expr->ts.type == BT_REAL && real_ok)))
{
if (real_ok)
gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
&expr->where);
else
gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
return FAILURE;
}
return SUCCESS;
}
try
gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
{
if (iter->var->ts.type == BT_REAL)
gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: REAL DO loop iterator at %L",
&iter->var->where);
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
== FAILURE)
return FAILURE;
if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
{
gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
&iter->var->where);
return FAILURE;
}
if (gfc_resolve_iterator_expr (iter->start, real_ok,
"Start expression in DO loop") == FAILURE)
return FAILURE;
if (gfc_resolve_iterator_expr (iter->end, real_ok,
"End expression in DO loop") == FAILURE)
return FAILURE;
if (gfc_resolve_iterator_expr (iter->step, real_ok,
"Step expression in DO loop") == FAILURE)
return FAILURE;
if (iter->step->expr_type == EXPR_CONSTANT)
{
if ((iter->step->ts.type == BT_INTEGER
&& mpz_cmp_ui (iter->step->value.integer, 0) == 0)
|| (iter->step->ts.type == BT_REAL
&& mpfr_sgn (iter->step->value.real) == 0))
{
gfc_error ("Step expression in DO loop at %L cannot be zero",
&iter->step->where);
return FAILURE;
}
}
if (iter->start->ts.kind != iter->var->ts.kind
|| iter->start->ts.type != iter->var->ts.type)
gfc_convert_type (iter->start, &iter->var->ts, 2);
if (iter->end->ts.kind != iter->var->ts.kind
|| iter->end->ts.type != iter->var->ts.type)
gfc_convert_type (iter->end, &iter->var->ts, 2);
if (iter->step->ts.kind != iter->var->ts.kind
|| iter->step->ts.type != iter->var->ts.type)
gfc_convert_type (iter->step, &iter->var->ts, 2);
return SUCCESS;
}
static void
resolve_forall_iterators (gfc_forall_iterator * iter)
{
while (iter)
{
if (gfc_resolve_expr (iter->var) == SUCCESS
&& (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
&iter->var->where);
if (gfc_resolve_expr (iter->start) == SUCCESS
&& (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
&iter->start->where);
if (iter->var->ts.kind != iter->start->ts.kind)
gfc_convert_type (iter->start, &iter->var->ts, 2);
if (gfc_resolve_expr (iter->end) == SUCCESS
&& (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
&iter->end->where);
if (iter->var->ts.kind != iter->end->ts.kind)
gfc_convert_type (iter->end, &iter->var->ts, 2);
if (gfc_resolve_expr (iter->stride) == SUCCESS)
{
if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
gfc_error ("FORALL stride expression at %L must be a scalar %s",
&iter->stride->where, "INTEGER");
if (iter->stride->expr_type == EXPR_CONSTANT
&& mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
gfc_error ("FORALL stride expression at %L cannot be zero",
&iter->stride->where);
}
if (iter->var->ts.kind != iter->stride->ts.kind)
gfc_convert_type (iter->stride, &iter->var->ts, 2);
iter = iter->next;
}
}
static int
derived_pointer (gfc_symbol * sym)
{
gfc_component *c;
for (c = sym->components; c; c = c->next)
{
if (c->pointer)
return 1;
if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
return 1;
}
return 0;
}
static int
derived_inaccessible (gfc_symbol *sym)
{
gfc_component *c;
if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
return 1;
for (c = sym->components; c; c = c->next)
{
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
return 1;
}
return 0;
}
static try
resolve_deallocate_expr (gfc_expr * e)
{
symbol_attribute attr;
int allocatable;
gfc_ref *ref;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
attr = gfc_expr_attr (e);
if (attr.pointer)
return SUCCESS;
if (e->expr_type != EXPR_VARIABLE)
goto bad;
allocatable = e->symtree->n.sym->attr.allocatable;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
if (ref->u.ar.type != AR_FULL)
allocatable = 0;
break;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
break;
case REF_SUBSTRING:
allocatable = 0;
break;
}
if (allocatable == 0)
{
bad:
gfc_error ("Expression in DEALLOCATE statement at %L must be "
"ALLOCATABLE or a POINTER", &e->where);
}
if (e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
return SUCCESS;
}
static bool
find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
{
gfc_actual_arglist *arg;
gfc_ref *ref;
int i;
bool rv = false;
if (e == NULL)
return rv;
switch (e->expr_type)
{
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
rv = rv || find_sym_in_expr (sym, arg->expr);
break;
case EXPR_VARIABLE:
if (sym == e->symtree->n.sym)
return true;
break;
case EXPR_OP:
rv = rv || find_sym_in_expr (sym, e->value.op.op1);
rv = rv || find_sym_in_expr (sym, e->value.op.op2);
break;
default:
break;
}
if (e->ref)
{
for (ref = e->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
}
break;
case REF_SUBSTRING:
rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
break;
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
&& ref->u.c.component->ts.cl->length->expr_type
!= EXPR_CONSTANT)
rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
if (ref->u.c.component->as)
for (i = 0; i < ref->u.c.component->as->rank; i++)
{
rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
}
break;
}
}
}
return rv;
}
static gfc_expr *
expr_to_initialize (gfc_expr * e)
{
gfc_expr *result;
gfc_ref *ref;
int i;
result = gfc_copy_expr (e);
for (ref = result->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
ref->u.ar.type = AR_FULL;
for (i = 0; i < ref->u.ar.dimen; i++)
ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
result->rank = ref->u.ar.dimen;
break;
}
return result;
}
static try
resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
int i, pointer, allocatable, dimension;
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;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
sym = code->expr->symtree->n.sym;
else
sym = NULL;
ref2 = NULL;
if (e->expr_type != EXPR_VARIABLE)
{
allocatable = 0;
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
}
else
{
allocatable = e->symtree->n.sym->attr.allocatable;
pointer = e->symtree->n.sym->attr.pointer;
dimension = e->symtree->n.sym->attr.dimension;
if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
{
gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
"not be allocated in the same statement at %L",
sym->name, &e->where);
return FAILURE;
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
if (ref->next != NULL)
pointer = 0;
break;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
pointer = ref->u.c.component->pointer;
dimension = ref->u.c.component->dimension;
break;
case REF_SUBSTRING:
allocatable = 0;
pointer = 0;
break;
}
}
if (allocatable == 0 && pointer == 0)
{
gfc_error ("Expression in ALLOCATE statement at %L must be "
"ALLOCATABLE or a POINTER", &e->where);
return FAILURE;
}
if (e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
}
if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
{
init_st = gfc_get_code ();
init_st->loc = code->loc;
init_st->op = EXEC_INIT_ASSIGN;
init_st->expr = 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 (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
return FAILURE;
}
ar = &ref2->u.ar;
for (i = 0; i < ar->dimen; i++)
{
if (ref2->u.ar.type == AR_ELEMENT)
goto check_symbols;
switch (ar->dimen_type[i])
{
case DIMEN_ELEMENT:
break;
case DIMEN_RANGE:
if (ar->start[i] != NULL
&& ar->end[i] != NULL
&& ar->stride[i] == NULL)
break;
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
return FAILURE;
}
check_symbols:
for (a = code->ext.alloc_list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
if (sym->ts.type == BT_DERIVED)
continue;
if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
|| (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
{
gfc_error ("'%s' must not appear an the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
return FAILURE;
}
}
}
return SUCCESS;
}
static int
compare_cases (const gfc_case * op1, const gfc_case * op2)
{
int retval;
if (op1->low == NULL)
{
retval = 0;
if (op2->low != NULL
&& gfc_compare_expr (op1->high, op2->low) < 0)
retval = -1;
}
else if (op1->high == NULL)
{
retval = 0;
if (op2->high != NULL
&& gfc_compare_expr (op1->low, op2->high) > 0)
retval = 1;
}
else
{
if (op2->low == NULL)
retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
else if (op2->high == NULL)
retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
else
{
retval = 0;
if (gfc_compare_expr (op1->high, op2->low) < 0)
retval = -1;
else if (gfc_compare_expr (op1->low, op2->high) > 0)
retval = 1;
}
}
return retval;
}
static gfc_case *
check_case_overlap (gfc_case * list)
{
gfc_case *p, *q, *e, *tail;
int insize, nmerges, psize, qsize, cmp, overlap_seen;
if (!list)
return NULL;
overlap_seen = 0;
insize = 1;
for (;;)
{
p = list;
list = NULL;
tail = NULL;
nmerges = 0;
while (p)
{
int i;
nmerges++;
psize = 0;
q = p;
for (i = 0; i < insize; i++)
{
psize++;
q = q->right;
if (!q)
break;
}
qsize = insize;
while (psize > 0 || (qsize > 0 && q != NULL))
{
if (psize == 0)
{
e = q;
q = q->right;
qsize--;
}
else if (qsize == 0 || q == NULL)
{
e = p;
p = p->right;
psize--;
}
else
{
cmp = compare_cases (p, q);
if (cmp < 0)
{
e = p;
p = p->right;
psize--;
}
else if (cmp > 0)
{
e = q;
q = q->right;
qsize--;
}
else
{
gfc_error ("CASE label at %L overlaps with CASE "
"label at %L", &p->where, &q->where);
overlap_seen = 1;
e = p;
p = p->right;
psize--;
}
}
if (tail)
tail->right = e;
else
list = e;
e->left = tail;
tail = e;
}
p = q;
}
tail->right = NULL;
if (nmerges <= 1)
{
if (!overlap_seen)
return list;
else
return NULL;
}
insize *= 2;
}
}
static try
validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
{
if (e == NULL) return SUCCESS;
if (e->ts.type != case_expr->ts.type)
{
gfc_error ("Expression in CASE statement at %L must be of type %s",
&e->where, gfc_basic_typename (case_expr->ts.type));
return FAILURE;
}
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
gfc_error("Expression in CASE statement at %L must be kind %d",
&e->where, case_expr->ts.kind);
return FAILURE;
}
if (e->ts.kind != case_expr->ts.kind)
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
if (e->rank != 0)
{
gfc_error ("Expression in CASE statement at %L must be scalar",
&e->where);
return FAILURE;
}
return SUCCESS;
}
static void
resolve_select (gfc_code * code)
{
gfc_code *body;
gfc_expr *case_expr;
gfc_case *cp, *default_case, *tail, *head;
int seen_unreachable;
int seen_logical;
int ncases;
bt type;
try t;
if (code->expr == NULL)
{
case_expr = code->expr2;
if (case_expr->ts.type != BT_INTEGER
|| case_expr->rank != 0)
gfc_error ("Selection expression in computed GOTO statement "
"at %L must be a scalar integer expression",
&case_expr->where);
code->expr = code->expr2;
code->expr2 = NULL;
return;
}
case_expr = code->expr;
type = case_expr->ts.type;
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
{
gfc_error ("Argument of SELECT statement at %L cannot be %s",
&case_expr->where, gfc_typename (&case_expr->ts));
return;
}
if (case_expr->rank != 0)
{
gfc_error ("Argument of SELECT statement at %L must be a scalar "
"expression", &case_expr->where);
return;
}
if (type == BT_LOGICAL || type == BT_INTEGER)
{
for (body = code->block; body; body = body->block)
{
for (cp = body->ext.case_list; cp; cp = cp->next)
{
if (cp->low == NULL && cp->high == NULL)
continue;
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
&& gfc_compare_expr (cp->low, cp->high) > 0)
continue;
if (cp->low != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
if (cp->high != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
}
}
}
default_case = NULL;
head = tail = NULL;
ncases = 0;
seen_logical = 0;
for (body = code->block; body; body = body->block)
{
t = SUCCESS;
seen_unreachable = 0;
for (cp = body->ext.case_list; cp; cp = cp->next)
{
ncases++;
if (cp->low == NULL && cp->high == NULL)
{
if (default_case != NULL)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->where, &cp->where);
t = FAILURE;
break;
}
else
{
default_case = cp;
continue;
}
}
if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
|| validate_case_label_expr (cp->high, case_expr) != SUCCESS)
{
t = FAILURE;
break;
}
if (type == BT_LOGICAL
&& ((cp->low == NULL || cp->high == NULL)
|| cp->low != cp->high))
{
gfc_error
("Logical range in CASE statement at %L is not allowed",
&cp->low->where);
t = FAILURE;
break;
}
if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
{
int value;
value = cp->low->value.logical == 0 ? 2 : 1;
if (value & seen_logical)
{
gfc_error ("constant logical value in CASE statement "
"is repeated at %L",
&cp->low->where);
t = FAILURE;
break;
}
seen_logical |= value;
}
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
&& gfc_compare_expr (cp->low, cp->high) > 0)
{
if (gfc_option.warn_surprising)
gfc_warning ("Range specification at %L can never "
"be matched", &cp->where);
cp->unreachable = 1;
seen_unreachable = 1;
}
else
{
if (!head)
{
head = tail = cp;
head->right = head->left = NULL;
}
else
{
tail->right = cp;
tail->right->left = tail;
tail = tail->right;
tail->right = NULL;
}
}
}
if (t == FAILURE)
continue;
if (seen_unreachable)
{
while (body->ext.case_list != NULL
&& body->ext.case_list->unreachable)
{
gfc_case *n = body->ext.case_list;
body->ext.case_list = body->ext.case_list->next;
n->next = NULL;
gfc_free_case_list (n);
}
if (body->ext.case_list)
{
for (cp = body->ext.case_list; cp->next; cp = cp->next)
{
if (cp->next->unreachable)
{
gfc_case *n = cp->next;
cp->next = cp->next->next;
n->next = NULL;
gfc_free_case_list (n);
}
}
}
}
}
if (head)
{
head = check_case_overlap (head);
if (head != NULL && default_case)
{
default_case->left = NULL;
default_case->right = head;
head->left = default_case;
}
}
for (body = code; body && body->block; body = body->block)
{
if (body->block->ext.case_list == NULL)
{
gfc_code *c = body->block;
body->block = c->block;
c->block = NULL;
gfc_free_statements (c);
}
}
if (gfc_option.warn_surprising && type == BT_LOGICAL
&& ncases > 2)
gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
&code->loc);
}
static void
resolve_transfer (gfc_code * code)
{
gfc_typespec *ts;
gfc_symbol *sym;
gfc_ref *ref;
gfc_expr *exp;
exp = code->expr;
if (exp->expr_type != EXPR_VARIABLE
&& exp->expr_type != EXPR_FUNCTION)
return;
sym = exp->symtree->n.sym;
ts = &sym->ts;
for (ref = code->expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
if (ts->type == BT_DERIVED)
{
if (derived_pointer (ts->derived))
{
gfc_error ("Data transfer element at %L cannot have "
"POINTER components", &code->loc);
return;
}
if (ts->derived->attr.alloc_comp)
{
gfc_error ("Data transfer element at %L cannot have "
"ALLOCATABLE components", &code->loc);
return;
}
if (derived_inaccessible (ts->derived))
{
gfc_error ("Data transfer element at %L cannot have "
"PRIVATE components",&code->loc);
return;
}
}
if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
&& exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
{
gfc_error ("Data transfer element at %L cannot be a full reference to "
"an assumed-size array", &code->loc);
return;
}
}
static void
resolve_branch (gfc_st_label * label, gfc_code * code)
{
gfc_code *block, *found;
code_stack *stack;
gfc_st_label *lp;
if (label == NULL)
return;
lp = label;
if (lp->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("Label %d referenced at %L is never defined", lp->value,
&lp->where);
return;
}
if (lp->defined != ST_LABEL_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
"for the branch statement at %L", &lp->where, &code->loc);
return;
}
if (code->here == label)
{
gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
return;
}
found = NULL;
for (stack = cs_base; stack; stack = stack->prev)
{
for (block = stack->head; block; block = block->next)
{
if (block->here == label)
{
found = block;
break;
}
}
if (found)
break;
}
if (found == NULL)
{
gfc_notify_std (GFC_STD_LEGACY,
"Label at %L is not in the same block as the "
"GOTO statement at %L", &lp->where, &code->loc);
return;
}
if (found->op == EXEC_NOP)
{
for (stack = cs_base; stack; stack = stack->prev)
if (stack->current->next == found)
break;
if (stack == NULL)
gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: GOTO at %L jumps to END of construct at %L",
&code->loc, &found->loc);
}
}
static try
resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
mpz_t shape2[GFC_MAX_DIMENSIONS];
try result = FAILURE;
int i;
if (expr1->rank != expr2->rank)
return result;
for (i=0; i<expr1->rank; i++)
{
if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
goto ignore;
if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
goto ignore;
if (mpz_cmp (shape[i], shape2[i]))
goto over;
}
ignore:
result = SUCCESS;
over:
for (i--; i>=0; i--)
{
mpz_clear (shape[i]);
mpz_clear (shape2[i]);
}
return result;
}
static void
resolve_where (gfc_code *code, gfc_expr *mask)
{
gfc_code *cblock;
gfc_code *cnext;
gfc_expr *e = NULL;
cblock = code->block;
if (mask == NULL)
e = cblock->expr;
else
e = mask;
while (cblock)
{
if (cblock->expr)
{
if (resolve_where_shape (cblock->expr, e) == FAILURE)
gfc_error ("WHERE mask at %L has inconsistent shape",
&cblock->expr->where);
}
cnext = cblock->next;
while (cnext)
{
switch (cnext->op)
{
case EXEC_ASSIGN:
if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
gfc_error ("WHERE assignment target at %L has "
"inconsistent shape", &cnext->expr->where);
break;
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
break;
case EXEC_WHERE:
resolve_where (cnext, e);
break;
default:
gfc_error ("Unsupported statement inside WHERE at %L",
&cnext->loc);
}
cnext = cnext->next;
}
cblock = cblock->block;
}
}
static try
gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
{
gfc_array_ref ar;
gfc_ref *tmp;
gfc_actual_arglist *args;
int i;
switch (expr->expr_type)
{
case EXPR_VARIABLE:
gcc_assert (expr->symtree->n.sym);
if (!expr->ref)
{
if (expr->symtree->n.sym == symbol)
return SUCCESS;
else
return FAILURE;
}
tmp = expr->ref;
while (tmp != NULL)
{
switch (tmp->type)
{
case REF_ARRAY:
ar = tmp->u.ar;
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
{
if (ar.start[i])
if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
return SUCCESS;
if (ar.end[i])
if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
return SUCCESS;
if (ar.stride[i])
if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
return SUCCESS;
}
break;
case REF_SUBSTRING:
if (expr->symtree->n.sym == symbol)
return SUCCESS;
tmp = expr->ref;
if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
return SUCCESS;
if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
return SUCCESS;
break;
case REF_COMPONENT:
break;
default:
gfc_error("expression reference type error at %L", &expr->where);
}
tmp = tmp->next;
}
break;
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
{
if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
return SUCCESS;
}
break;
case EXPR_SUBSTRING:
if (expr->ref)
{
tmp = expr->ref;
gcc_assert (expr->ref->type == REF_SUBSTRING);
if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
return SUCCESS;
if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
return SUCCESS;
}
break;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
gfc_error ("Unsupported statement while finding forall index in "
"expression");
break;
case EXPR_OP:
if (expr->value.op.op1)
{
if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
return SUCCESS;
}
if (expr->value.op.op2)
{
if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
return SUCCESS;
}
break;
default:
break;
}
return FAILURE;
}
static void
gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
{
int n;
for (n = 0; n < nvar; n++)
{
gfc_symbol *forall_index;
forall_index = var_expr[n]->symtree->n.sym;
if ((code->expr->expr_type == EXPR_VARIABLE)
&& (code->expr->symtree->n.sym == forall_index))
gfc_error ("Assignment to a FORALL index variable at %L",
&code->expr->where);
else
{
if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
gfc_error ("The FORALL with index '%s' cause more than one "
"assignment to this object at %L",
var_expr[n]->symtree->name, &code->expr->where);
}
}
}
static void
gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
gfc_code *cblock;
gfc_code *cnext;
cblock = code->block;
while (cblock)
{
cnext = cblock->next;
while (cnext)
{
switch (cnext->op)
{
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
break;
case EXEC_WHERE:
gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
break;
default:
gfc_error ("Unsupported statement inside WHERE at %L",
&cnext->loc);
}
cnext = cnext->next;
}
cblock = cblock->block;
}
}
static void
gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
{
gfc_code *c;
c = code->block->next;
while (c)
{
switch (c->op)
{
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
gfc_resolve_assign_in_forall (c, nvar, var_expr);
break;
case EXEC_ASSIGN_CALL:
resolve_call (c);
break;
case EXEC_FORALL:
break;
case EXEC_WHERE:
gfc_resolve_where_code_in_forall(c, nvar, var_expr);
break;
default:
break;
}
c = c->next;
}
}
static void
gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
{
static gfc_expr **var_expr;
static int total_var = 0;
static int nvar = 0;
gfc_forall_iterator *fa;
gfc_symbol *forall_index;
gfc_code *next;
int i;
if (forall_save == 0)
{
next = code;
while ((next != NULL) && (next->op == EXEC_FORALL))
{
for (fa = next->ext.forall_iterator; fa; fa = fa->next)
total_var ++;
next = next->block->next;
}
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
}
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
{
for (i = 0; i < nvar; i++)
{
if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
{
gfc_error ("An outer FORALL construct already has an index "
"with this name %L", &fa->var->where);
}
}
var_expr[nvar] = gfc_copy_expr (fa->var);
forall_index = fa->var->symtree->n.sym;
if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
gfc_error ("A FORALL index must not appear in a limit or stride "
"expression in the same FORALL at %L", &fa->start->where);
if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
gfc_error ("A FORALL index must not appear in a limit or stride "
"expression in the same FORALL at %L", &fa->end->where);
if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
gfc_error ("A FORALL index must not appear in a limit or stride "
"expression in the same FORALL at %L", &fa->stride->where);
nvar++;
}
gfc_resolve_forall_body (code, nvar, var_expr);
gfc_resolve_blocks (code->block, ns);
for (i = 0; i < total_var; i++)
gfc_free_expr (var_expr[i]);
total_var = 0;
nvar = 0;
}
static void resolve_code (gfc_code *, gfc_namespace *);
void
gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
{
try t;
for (; b; b = b->block)
{
t = gfc_resolve_expr (b->expr);
if (gfc_resolve_expr (b->expr2) == FAILURE)
t = FAILURE;
switch (b->op)
{
case EXEC_IF:
if (t == SUCCESS && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
gfc_error
("IF clause at %L requires a scalar LOGICAL expression",
&b->expr->where);
break;
case EXEC_WHERE:
if (t == SUCCESS
&& b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL
|| b->expr->rank == 0))
gfc_error
("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
&b->expr->where);
break;
case EXEC_GOTO:
resolve_branch (b->label, b);
break;
case EXEC_SELECT:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DO:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
break;
default:
gfc_internal_error ("resolve_block(): Bad block type");
}
resolve_code (b->next, ns);
}
}
static void
resolve_code (gfc_code * code, gfc_namespace * ns)
{
int omp_workshare_save;
int forall_save;
code_stack frame;
gfc_alloc *a;
try t;
frame.prev = cs_base;
frame.head = code;
cs_base = &frame;
for (; code; code = code->next)
{
frame.current = code;
forall_save = forall_flag;
if (code->op == EXEC_FORALL)
{
forall_flag = 1;
gfc_resolve_forall (code, ns, forall_save);
forall_flag = 2;
}
else if (code->block)
{
omp_workshare_save = -1;
switch (code->op)
{
case EXEC_OMP_PARALLEL_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
gfc_resolve_omp_parallel_blocks (code, ns);
break;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_parallel_blocks (code, ns);
break;
case EXEC_OMP_DO:
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
default:
gfc_resolve_blocks (code->block, ns);
break;
}
if (omp_workshare_save != -1)
omp_workshare_flag = omp_workshare_save;
}
t = gfc_resolve_expr (code->expr);
forall_flag = forall_save;
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
switch (code->op)
{
case EXEC_NOP:
case EXEC_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
break;
case EXEC_ENTRY:
current_entry_id = code->ext.entry->id;
break;
case EXEC_WHERE:
resolve_where (code, NULL);
break;
case EXEC_GOTO:
if (code->expr != NULL)
{
if (code->expr->ts.type != BT_INTEGER)
gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
"variable", &code->expr->where);
else if (code->expr->symtree->n.sym->attr.assign != 1)
gfc_error ("Variable '%s' has not been assigned a target label "
"at %L", code->expr->symtree->n.sym->name,
&code->expr->where);
}
else
resolve_branch (code->label, code);
break;
case EXEC_RETURN:
if (code->expr != NULL
&& (code->expr->ts.type != BT_INTEGER || code->expr->rank))
gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
"INTEGER return specifier", &code->expr->where);
break;
case EXEC_INIT_ASSIGN:
break;
case EXEC_ASSIGN:
if (t == FAILURE)
break;
if (gfc_extend_assign (code, ns) == SUCCESS)
{
if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
{
gfc_error ("Subroutine '%s' called instead of assignment at "
"%L must be PURE", code->symtree->n.sym->name,
&code->loc);
break;
}
goto call;
}
if (code->expr->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
int llen = 0, rlen = 0;
if (code->expr->ts.cl != NULL
&& code->expr->ts.cl->length != NULL
&& code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
if (code->expr2->expr_type == EXPR_CONSTANT)
rlen = code->expr2->value.character.length;
else if (code->expr2->ts.cl != NULL
&& code->expr2->ts.cl->length != NULL
&& code->expr2->ts.cl->length->expr_type == EXPR_CONSTANT)
rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
if (rlen && llen && rlen > llen)
gfc_warning_now ("rhs of CHARACTER assignment at %L will "
"be truncated (%d/%d)", &code->loc, rlen, llen);
}
if (gfc_pure (NULL))
{
if (gfc_impure_variable (code->expr->symtree->n.sym))
{
gfc_error
("Cannot assign to variable '%s' in PURE procedure at %L",
code->expr->symtree->n.sym->name, &code->expr->where);
break;
}
if (code->expr2->ts.type == BT_DERIVED
&& derived_pointer (code->expr2->ts.derived))
{
gfc_error
("Right side of assignment at %L is a derived type "
"containing a POINTER in a PURE procedure",
&code->expr2->where);
break;
}
}
gfc_check_assign (code->expr, code->expr2, 1);
break;
case EXEC_LABEL_ASSIGN:
if (code->label->defined == ST_LABEL_UNKNOWN)
gfc_error ("Label %d referenced at %L is never defined",
code->label->value, &code->label->where);
if (t == SUCCESS
&& (code->expr->expr_type != EXPR_VARIABLE
|| code->expr->symtree->n.sym->ts.type != BT_INTEGER
|| code->expr->symtree->n.sym->ts.kind
!= gfc_default_integer_kind
|| code->expr->symtree->n.sym->as != NULL))
gfc_error ("ASSIGN statement at %L requires a scalar "
"default INTEGER variable", &code->expr->where);
break;
case EXEC_POINTER_ASSIGN:
if (t == FAILURE)
break;
gfc_check_pointer_assign (code->expr, code->expr2);
break;
case EXEC_ARITHMETIC_IF:
if (t == SUCCESS
&& code->expr->ts.type != BT_INTEGER
&& code->expr->ts.type != BT_REAL)
gfc_error ("Arithmetic IF statement at %L requires a numeric "
"expression", &code->expr->where);
resolve_branch (code->label, code);
resolve_branch (code->label2, code);
resolve_branch (code->label3, code);
break;
case EXEC_IF:
if (t == SUCCESS && code->expr != NULL
&& (code->expr->ts.type != BT_LOGICAL
|| code->expr->rank != 0))
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
&code->expr->where);
break;
case EXEC_CALL:
call:
resolve_call (code);
break;
case EXEC_SELECT:
resolve_select (code);
break;
case EXEC_DO:
if (code->ext.iterator != NULL)
{
gfc_iterator *iter = code->ext.iterator;
if (gfc_resolve_iterator (iter, true) != FAILURE)
gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
}
break;
case EXEC_DO_WHILE:
if (code->expr == NULL)
gfc_internal_error ("resolve_code(): No expression on DO WHILE");
if (t == SUCCESS
&& (code->expr->rank != 0
|| code->expr->ts.type != BT_LOGICAL))
gfc_error ("Exit condition of DO WHILE loop at %L must be "
"a scalar LOGICAL expression", &code->expr->where);
break;
case EXEC_ALLOCATE:
if (t == SUCCESS && code->expr != NULL
&& code->expr->ts.type != BT_INTEGER)
gfc_error ("STAT tag in ALLOCATE statement at %L must be "
"of type INTEGER", &code->expr->where);
for (a = code->ext.alloc_list; a; a = a->next)
resolve_allocate_expr (a->expr, code);
break;
case EXEC_DEALLOCATE:
if (t == SUCCESS && code->expr != NULL
&& code->expr->ts.type != BT_INTEGER)
gfc_error
("STAT tag in DEALLOCATE statement at %L must be of type "
"INTEGER", &code->expr->where);
for (a = code->ext.alloc_list; a; a = a->next)
resolve_deallocate_expr (a->expr);
break;
case EXEC_OPEN:
if (gfc_resolve_open (code->ext.open) == FAILURE)
break;
resolve_branch (code->ext.open->err, code);
break;
case EXEC_CLOSE:
if (gfc_resolve_close (code->ext.close) == FAILURE)
break;
resolve_branch (code->ext.close->err, code);
break;
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
case EXEC_FLUSH:
if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
break;
resolve_branch (code->ext.filepos->err, code);
break;
case EXEC_INQUIRE:
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
break;
resolve_branch (code->ext.inquire->err, code);
break;
case EXEC_IOLENGTH:
gcc_assert (code->ext.inquire != NULL);
if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
break;
resolve_branch (code->ext.inquire->err, code);
break;
case EXEC_READ:
case EXEC_WRITE:
if (gfc_resolve_dt (code->ext.dt) == FAILURE)
break;
resolve_branch (code->ext.dt->err, code);
resolve_branch (code->ext.dt->end, code);
resolve_branch (code->ext.dt->eor, code);
break;
case EXEC_TRANSFER:
resolve_transfer (code);
break;
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
gfc_error
("FORALL mask clause at %L requires a LOGICAL expression",
&code->expr->where);
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DO:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_directive (code, ns);
omp_workshare_flag = omp_workshare_save;
break;
default:
gfc_internal_error ("resolve_code(): Bad statement code");
}
}
cs_base = frame.prev;
}
static void
resolve_values (gfc_symbol * sym)
{
if (sym->value == NULL)
return;
if (gfc_resolve_expr (sym->value) == FAILURE)
return;
gfc_check_assign_symbol (sym, sym->value);
}
static try
resolve_index_expr (gfc_expr * e)
{
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (e, 0) == FAILURE)
return FAILURE;
if (gfc_specification_expr (e) == FAILURE)
return FAILURE;
return SUCCESS;
}
static try
resolve_charlen (gfc_charlen *cl)
{
if (cl->resolved)
return SUCCESS;
cl->resolved = 1;
specification_expr = 1;
if (resolve_index_expr (cl->length) == FAILURE)
{
specification_expr = 0;
return FAILURE;
}
return SUCCESS;
}
static bool
is_non_constant_shape_array (gfc_symbol *sym)
{
gfc_expr *e;
int i;
bool not_constant;
not_constant = false;
if (sym->as != NULL)
{
for (i = 0; i < sym->as->rank; 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)))
not_constant = true;
}
}
return not_constant;
}
static void
apply_default_init (gfc_symbol *sym)
{
gfc_expr *lval;
gfc_expr *init = NULL;
gfc_code *init_st;
gfc_namespace *ns = sym->ns;
if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
return;
if (sym->ts.type == BT_DERIVED && sym->ts.derived)
init = gfc_default_initializer (&sym->ts);
if (init == NULL)
return;
if (sym->attr.function && sym == sym->result
&& sym->name != sym->ns->proc_name->name)
{
ns = ns->contained;
for (;ns; ns = ns->sibling)
if (strcmp (ns->proc_name->name, sym->name) == 0)
break;
}
if (ns == NULL)
{
gfc_free_expr (init);
return;
}
lval = gfc_get_expr ();
lval->expr_type = EXPR_VARIABLE;
lval->where = sym->declared_at;
lval->ts = sym->ts;
lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
lval->rank = sym->as ? sym->as->rank : 0;
if (lval->rank)
{
lval->ref = gfc_get_ref ();
lval->ref->type = REF_ARRAY;
lval->ref->u.ar.type = AR_FULL;
lval->ref->u.ar.dimen = lval->rank;
lval->ref->u.ar.where = sym->declared_at;
lval->ref->u.ar.as = sym->as;
}
init_st = gfc_get_code ();
init_st->next = ns->code;
ns->code = init_st;
init_st->loc = sym->declared_at;
init_st->op = EXEC_INIT_ASSIGN;
init_st->expr = lval;
init_st->expr2 = init;
}
static try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
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);
return FAILURE;
}
if (sym->attr.pointer && sym->attr.dimension)
{
gfc_error ("Array pointer '%s' at %L must have a deferred shape",
sym->name, &sym->declared_at);
return FAILURE;
}
}
else
{
if (!mp_flag && !sym->attr.allocatable
&& !sym->attr.pointer && !sym->attr.dummy)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
return FAILURE;
}
}
return SUCCESS;
}
static gfc_component *
has_default_initializer (gfc_symbol *der)
{
gfc_component *c;
for (c = der->components; c; c = c->next)
if ((c->ts.type != BT_DERIVED && c->initializer)
|| (c->ts.type == BT_DERIVED
&& !c->pointer
&& has_default_initializer (c->ts.derived)))
break;
return c;
}
static try
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
int flag;
int i;
gfc_expr *e;
gfc_component *c;
const char * auto_save_msg;
auto_save_msg = "automatic object '%s' at %L cannot have the "
"SAVE attribute";
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
specification_expr = 1;
if (!sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program))
{
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
specification_expr = 0;
return FAILURE;
}
}
if (sym->ts.type == BT_CHARACTER)
{
e = sym->ts.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
return FAILURE;
}
if (e && sym->attr.save && !gfc_is_constant_expr (e))
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
}
if (!gfc_is_constant_expr (e)
&& !(e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
&& sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)
&& !sym->attr.use_assoc)
{
gfc_error ("'%s' at %L must have constant character length "
"in this context", sym->name, &sym->declared_at);
return FAILURE;
}
}
flag = 0;
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
flag = 1;
else if (sym->attr.dimension && !sym->attr.pointer)
{
for (i = 0; i < sym->as->rank; i++)
{
if (sym->as->lower[i] == NULL
|| sym->as->lower[i]->expr_type != EXPR_CONSTANT
|| sym->as->upper[i] == NULL
|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{
flag = 1;
break;
}
}
if (flag && sym->attr.save)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
}
}
if (sym->value && flag)
{
if (sym->attr.allocatable)
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.external)
gfc_error ("External '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.dummy)
gfc_error ("Dummy '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.intrinsic)
gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.result)
gfc_error ("Function result '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns)
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
if (s && (s->attr.flavor != FL_DERIVED
|| !gfc_compare_derived_types (s, sym->ts.derived)))
{
gfc_error ("The type %s cannot be host associated at %L because "
"it is blocked by an incompatible object of the same "
"name at %L", sym->ts.derived->name, &sym->declared_at,
&s->declared_at);
return FAILURE;
}
}
c = NULL;
if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
c = has_default_initializer (sym->ts.derived);
if (c && sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable)
{
gfc_error("Object '%s' at %L must have the SAVE attribute %s",
sym->name, &sym->declared_at,
"for default initialization of a component");
return FAILURE;
}
if (sym->ts.type == BT_DERIVED
&& !sym->value
&& !sym->attr.pointer
&& !sym->attr.allocatable
&& (!flag || sym->attr.intent == INTENT_OUT))
sym->value = gfc_default_initializer (&sym->ts);
return SUCCESS;
}
static try
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
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;
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.cl;
if (cl && cl->length && gfc_is_constant_expr (cl->length)
&& resolve_charlen (cl) == FAILURE)
return FAILURE;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
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;
}
}
}
if (!(sym->ns->parent
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
{
for (arg = sym->formal; arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.derived->attr.use_assoc
&& !gfc_check_access(arg->sym->ts.derived->attr.access,
arg->sym->ts.derived->ns->default_access))
{
gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
"a dummy argument of '%s', which is "
"PUBLIC at %L", arg->sym->name, sym->name,
&sym->declared_at);
arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
}
if (sym->attr.external && sym->value)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.elemental && sym->attr.function && sym->as)
{
gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
"result", sym->name, &sym->declared_at);
sym->attr.elemental = 0;
return FAILURE;
}
if (sym->attr.function
&& sym->ts.type == BT_CHARACTER
&& sym->ts.cl && sym->ts.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
|| (sym->attr.recursive) || (sym->attr.pure))
{
if (sym->as && sym->as->rank)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"array-valued", sym->name, &sym->declared_at);
if (sym->attr.pointer)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"pointer-valued", sym->name, &sym->declared_at);
if (sym->attr.pure)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"pure", sym->name, &sym->declared_at);
if (sym->attr.recursive)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"recursive", sym->name, &sym->declared_at);
return FAILURE;
}
if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
"'%s' at %L is obsolescent in fortran 95",
sym->name, &sym->declared_at);
}
return SUCCESS;
}
static try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
gfc_dt_list * dt_list;
int i;
for (c = sym->components; c != NULL; c = c->next)
{
if (c->ts.type == BT_CHARACTER)
{
if (c->ts.cl->length == NULL
|| (resolve_charlen (c->ts.cl) == FAILURE)
|| !gfc_is_constant_expr (c->ts.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
"be a constant specification expression at %L.",
c->name,
c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
&& gfc_check_access(sym->attr.access, sym->ns->default_access)
&& !c->ts.derived->attr.use_assoc
&& !gfc_check_access(c->ts.derived->attr.access,
c->ts.derived->ns->default_access))
{
gfc_error ("The component '%s' is a PRIVATE type and cannot be "
"a component of '%s', which is PUBLIC at %L",
c->name, sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.sequence)
{
if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
{
gfc_error ("Component %s of SEQUENCE type declared at %L does "
"not have the SEQUENCE attribute",
c->ts.derived->name, &sym->declared_at);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED && c->pointer
&& c->ts.derived->components == NULL)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
&c->loc);
return FAILURE;
}
if (c->pointer || c->allocatable || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
{
if (c->as->lower[i] == NULL
|| !gfc_is_constant_expr (c->as->lower[i])
|| (resolve_index_expr (c->as->lower[i]) == FAILURE)
|| c->as->upper[i] == NULL
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|| !gfc_is_constant_expr (c->as->upper[i]))
{
gfc_error ("Component '%s' of '%s' at %L must have "
"constant array bounds.",
c->name, sym->name, &c->loc);
return FAILURE;
}
}
}
for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next)
if (sym == dt_list->derived)
break;
if (dt_list == NULL)
{
dt_list = gfc_get_dt_list ();
dt_list->next = sym->ns->derived_types;
dt_list->derived = sym;
sym->ns->derived_types = dt_list;
}
return SUCCESS;
}
static try
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
gfc_symbol *nlsym;
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
{
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
&& !(sym->ns->parent == nl->sym->ns)
&& !gfc_check_access(nl->sym->attr.access,
nl->sym->ns->default_access))
{
gfc_error ("PRIVATE symbol '%s' cannot be member of "
"PUBLIC namelist at %L", nl->sym->name,
&sym->declared_at);
return FAILURE;
}
}
}
for (nl = sym->namelist; nl; nl = nl->next)
{
if (is_non_constant_shape_array (nl->sym))
{
gfc_error ("The array '%s' must have constant shape to be "
"a NAMELIST object at %L", nl->sym->name,
&sym->declared_at);
return FAILURE;
}
}
for (nl = sym->namelist; nl; nl = nl->next)
{
if (nl->sym->ts.type == BT_DERIVED
&& nl->sym->ts.derived->attr.alloc_comp)
{
gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
"components", nl->sym->name, &sym->declared_at);
return FAILURE;
}
}
for (nl = sym->namelist; nl; nl = nl->next)
{
if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
continue;
nlsym = NULL;
if (sym->ns->parent && nl->sym && nl->sym->name)
gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
{
gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
"attribute in '%s' at %L", nlsym->name,
&sym->declared_at);
return FAILURE;
}
}
return SUCCESS;
}
static try
resolve_fl_parameter (gfc_symbol *sym)
{
if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
{
gfc_error ("Parameter array '%s' at %L cannot be automatic "
"or assumed shape", sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.implicit_type
&& !gfc_compare_types (&sym->ts,
gfc_get_default_type (sym, sym->ns)))
{
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->ts.type == BT_DERIVED
&& !gfc_compare_types (&sym->ts, &sym->value->ts))
{
gfc_error ("Incompatible derived type in PARAMETER at %L",
&sym->value->where);
return FAILURE;
}
return SUCCESS;
}
static void
resolve_symbol (gfc_symbol * sym)
{
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
gfc_component *c;
if (sym->attr.flavor == FL_UNKNOWN)
{
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
{
symtree = gfc_find_symtree (ns->sym_root, sym->name);
if (symtree && symtree->n.sym->generic)
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
sym->refs--;
if (!sym->refs)
gfc_free_symbol (sym);
symtree->n.sym->refs++;
this_symtree->n.sym = symtree->n.sym;
return;
}
}
if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
sym->attr.flavor = FL_VARIABLE;
else
{
sym->attr.flavor = FL_PROCEDURE;
if (sym->attr.dimension)
sym->attr.function = 1;
}
}
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
mp_flag = (sym->result != NULL && sym->result != sym);
if (sym->ts.type == BT_UNKNOWN)
{
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
gfc_set_default_type (sym, 1, NULL);
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
{
if (!mp_flag)
gfc_set_default_type (sym, sym->attr.external, NULL);
else
{
resolve_symbol (sym->result);
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
}
}
}
if (sym->as != NULL
&& (sym->as->type == AS_ASSUMED_SIZE
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
if (sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array at %L must be a dummy argument",
&sym->declared_at);
else
gfc_error ("Assumed shape array at %L must be a dummy argument",
&sym->declared_at);
return;
}
if (!sym->attr.dummy
&& (sym->attr.optional
|| sym->attr.intent != INTENT_UNKNOWN))
{
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return;
}
if (sym->ts.type == BT_DERIVED
&& sym->ts.derived->components == NULL)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined.", sym->name,
&sym->declared_at, sym->ts.derived->name);
sym->ts.type = BT_UNKNOWN;
return;
}
if (sym->ts.type == BT_DERIVED
&& sym->attr.dummy
&& sym->attr.intent == INTENT_OUT
&& sym->as
&& sym->as->type == AS_ASSUMED_SIZE)
{
for (c = sym->ts.derived->components; c; c = c->next)
{
if (c->initializer)
{
gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
"ASSUMED SIZE and so cannot have a default initializer",
sym->name, &sym->declared_at);
return;
}
}
}
switch (sym->attr.flavor)
{
case FL_VARIABLE:
if (resolve_fl_variable (sym, mp_flag) == FAILURE)
return;
break;
case FL_PROCEDURE:
if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
return;
break;
case FL_NAMELIST:
if (resolve_fl_namelist (sym) == FAILURE)
return;
break;
case FL_PARAMETER:
if (resolve_fl_parameter (sym) == FAILURE)
return;
break;
default:
break;
}
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
&& ! gfc_intrinsic_name(sym->name, 1))
gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
check_constant = sym->attr.in_common && !sym->attr.pointer;
if (sym->attr.function && sym->as)
formal_arg_flag = 1;
gfc_resolve_array_spec (sym->as, check_constant);
formal_arg_flag = 0;
if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
{
formal_ns_save = formal_ns_flag;
formal_ns_flag = 0;
gfc_resolve (sym->formal_ns);
formal_ns_flag = formal_ns_save;
}
if (sym->attr.threadprivate && !sym->attr.save
&& (!sym->attr.in_common
&& sym->module == NULL
&& (sym->ns->proc_name == NULL
|| sym->ns->proc_name->attr.flavor != FL_MODULE)))
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
if (sym->ts.type == BT_DERIVED
&& sym->attr.referenced
&& sym->ns == gfc_current_ns
&& !sym->value
&& !sym->attr.allocatable
&& !sym->attr.alloc_comp)
{
symbol_attribute *a = &sym->attr;
if ((!a->save && !a->dummy && !a->pointer
&& !a->in_common && !a->use_assoc
&& !(a->function && sym != sym->result))
||
(a->dummy && a->intent == INTENT_OUT))
apply_default_init (sym);
}
}
static struct
{
gfc_data_value *vnode;
unsigned int left;
}
values;
static try
next_data_value (void)
{
while (values.left == 0)
{
if (values.vnode->next == NULL)
return FAILURE;
values.vnode = values.vnode->next;
values.left = values.vnode->repeat;
}
return SUCCESS;
}
static try
check_data_variable (gfc_data_variable * var, locus * where)
{
gfc_expr *e;
mpz_t size;
mpz_t offset;
try t;
ar_type mark = AR_UNKNOWN;
int i;
mpz_t section_index[GFC_MAX_DIMENSIONS];
gfc_ref *ref;
gfc_array_ref *ar;
if (gfc_resolve_expr (var->expr) == FAILURE)
return FAILURE;
ar = NULL;
mpz_init_set_si (offset, 0);
e = var->expr;
if (e->expr_type != EXPR_VARIABLE)
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->symtree->n.sym->ns->is_block_data
&& !e->symtree->n.sym->attr.in_common)
{
gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
}
if (e->rank == 0)
{
mpz_init_set_ui (size, 1);
ref = NULL;
}
else
{
ref = e->ref;
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type != REF_ARRAY)
continue;
if (ref->u.ar.type == AR_ELEMENT)
continue;
break;
}
gcc_assert (ref);
switch (ref->u.ar.type)
{
case AR_FULL:
mark = AR_FULL;
break;
case AR_SECTION:
ar = &ref->u.ar;
gfc_get_section_index (ar, section_index, &offset);
mark = AR_SECTION;
break;
default:
gcc_unreachable ();
}
if (gfc_array_size (e, &size) == FAILURE)
{
gfc_error ("Nonconstant array section at %L in DATA statement",
&e->where);
mpz_clear (offset);
return FAILURE;
}
}
t = SUCCESS;
while (mpz_cmp_ui (size, 0) > 0)
{
if (next_data_value () == FAILURE)
{
gfc_error ("DATA statement at %L has more variables than values",
where);
t = FAILURE;
break;
}
t = gfc_check_assign (var->expr, values.vnode->expr, 0);
if (t == FAILURE)
break;
if (mark == AR_FULL && ref && ref->next == NULL
&& values.left > 1 && mpz_cmp_ui (size, 1) > 0)
{
mpz_t range;
if (mpz_cmp_ui (size, values.left) >= 0)
{
mpz_init_set_ui (range, values.left);
mpz_sub_ui (size, size, values.left);
values.left = 0;
}
else
{
mpz_init_set (range, size);
values.left -= mpz_get_ui (size);
mpz_set_ui (size, 0);
}
gfc_assign_data_value_range (var->expr, values.vnode->expr,
offset, range);
mpz_add (offset, offset, range);
mpz_clear (range);
}
else
{
values.left -= 1;
mpz_sub_ui (size, size, 1);
gfc_assign_data_value (var->expr, values.vnode->expr, offset);
if (mark == AR_FULL)
mpz_add_ui (offset, offset, 1);
else if (mark == AR_SECTION)
gfc_advance_section (section_index, ar, &offset);
}
}
if (mark == AR_SECTION)
{
for (i = 0; i < ar->dimen; i++)
mpz_clear (section_index[i]);
}
mpz_clear (size);
mpz_clear (offset);
return t;
}
static try traverse_data_var (gfc_data_variable *, locus *);
static try
traverse_data_list (gfc_data_variable * var, locus * where)
{
mpz_t trip;
iterator_stack frame;
gfc_expr *e, *start, *end, *step;
try retval = SUCCESS;
mpz_init (frame.value);
start = gfc_copy_expr (var->iter.start);
end = gfc_copy_expr (var->iter.end);
step = gfc_copy_expr (var->iter.step);
if (gfc_simplify_expr (start, 1) == FAILURE
|| start->expr_type != EXPR_CONSTANT)
{
gfc_error ("iterator start at %L does not simplify",
&start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (end, 1) == FAILURE
|| end->expr_type != EXPR_CONSTANT)
{
gfc_error ("iterator end at %L does not simplify",
&end->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (step, 1) == FAILURE
|| step->expr_type != EXPR_CONSTANT)
{
gfc_error ("iterator step at %L does not simplify",
&step->where);
retval = FAILURE;
goto cleanup;
}
mpz_init_set (trip, end->value.integer);
mpz_sub (trip, trip, start->value.integer);
mpz_add (trip, trip, step->value.integer);
mpz_div (trip, trip, step->value.integer);
mpz_set (frame.value, start->value.integer);
frame.prev = iter_stack;
frame.variable = var->iter.var->symtree;
iter_stack = &frame;
while (mpz_cmp_ui (trip, 0) > 0)
{
if (traverse_data_var (var->list, where) == FAILURE)
{
mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
e = gfc_copy_expr (var->expr);
if (gfc_simplify_expr (e, 1) == FAILURE)
{
gfc_free_expr (e);
mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
mpz_add (frame.value, frame.value, step->value.integer);
mpz_sub_ui (trip, trip, 1);
}
mpz_clear (trip);
cleanup:
mpz_clear (frame.value);
gfc_free_expr (start);
gfc_free_expr (end);
gfc_free_expr (step);
iter_stack = frame.prev;
return retval;
}
static try
traverse_data_var (gfc_data_variable * var, locus * where)
{
try t;
for (; var; var = var->next)
{
if (var->expr == NULL)
t = traverse_data_list (var, where);
else
t = check_data_variable (var, where);
if (t == FAILURE)
return FAILURE;
}
return SUCCESS;
}
static try
resolve_data_variables (gfc_data_variable * d)
{
for (; d; d = d->next)
{
if (d->list == NULL)
{
if (gfc_resolve_expr (d->expr) == FAILURE)
return FAILURE;
}
else
{
if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
return FAILURE;
if (resolve_data_variables (d->list) == FAILURE)
return FAILURE;
}
}
return SUCCESS;
}
static void
resolve_data (gfc_data * d)
{
if (resolve_data_variables (d->var) == FAILURE)
return;
values.vnode = d->value;
values.left = (d->value == NULL) ? 0 : d->value->repeat;
if (traverse_data_var (d->var, &d->where) == FAILURE)
return;
if (next_data_value () == SUCCESS)
gfc_error ("DATA statement at %L has more values than variables",
&d->where);
}
int
gfc_impure_variable (gfc_symbol * sym)
{
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
if (sym->ns != gfc_current_ns)
return !sym->attr.function;
return 0;
}
int
gfc_pure (gfc_symbol * sym)
{
symbol_attribute attr;
if (sym == NULL)
sym = gfc_current_ns->proc_name;
if (sym == NULL)
return 0;
attr = sym->attr;
return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
}
int
gfc_elemental (gfc_symbol * sym)
{
symbol_attribute attr;
if (sym == NULL)
sym = gfc_current_ns->proc_name;
if (sym == NULL)
return 0;
attr = sym->attr;
return attr.flavor == FL_PROCEDURE && attr.elemental;
}
static void
warn_unused_fortran_label (gfc_st_label * label)
{
if (label == NULL)
return;
warn_unused_fortran_label (label->left);
if (label->defined == ST_LABEL_UNKNOWN)
return;
switch (label->referenced)
{
case ST_LABEL_UNKNOWN:
gfc_warning ("Label %d at %L defined but not used", label->value,
&label->where);
break;
case ST_LABEL_BAD_TARGET:
gfc_warning ("Label %d at %L defined but cannot be used",
label->value, &label->where);
break;
default:
break;
}
warn_unused_fortran_label (label->right);
}
static seq_type
sequence_type (gfc_typespec ts)
{
seq_type result;
gfc_component *c;
switch (ts.type)
{
case BT_DERIVED:
if (ts.derived->components == NULL)
return SEQ_NONDEFAULT;
result = sequence_type (ts.derived->components->ts);
for (c = ts.derived->components->next; c; c = c->next)
if (sequence_type (c->ts) != result)
return SEQ_MIXED;
return result;
case BT_CHARACTER:
if (ts.kind != gfc_default_character_kind)
return SEQ_NONDEFAULT;
return SEQ_CHARACTER;
case BT_INTEGER:
if (ts.kind != gfc_default_integer_kind)
return SEQ_NONDEFAULT;
return SEQ_NUMERIC;
case BT_REAL:
if (!(ts.kind == gfc_default_real_kind
|| ts.kind == gfc_default_double_kind))
return SEQ_NONDEFAULT;
return SEQ_NUMERIC;
case BT_COMPLEX:
if (ts.kind != gfc_default_complex_kind)
return SEQ_NONDEFAULT;
return SEQ_NUMERIC;
case BT_LOGICAL:
if (ts.kind != gfc_default_logical_kind)
return SEQ_NONDEFAULT;
return SEQ_NUMERIC;
default:
return SEQ_NONDEFAULT;
}
}
static try
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
{
gfc_symbol *d;
gfc_component *c = derived->components;
if (!derived)
return SUCCESS;
if (!derived->attr.sequence)
{
gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
"attribute to be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
if (derived->attr.alloc_comp)
{
gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
"components to be an EQUIVALENCE object",sym->name, &e->where);
return FAILURE;
}
for (; c ; c = c->next)
{
d = c->ts.derived;
if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
return FAILURE;
if (c->pointer)
{
gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
"cannot be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
if (c->initializer)
{
gfc_error ("Derived type variable '%s' at %L with default initializer "
"cannot be an EQUIVALENCE object", sym->name, &e->where);
return FAILURE;
}
}
return SUCCESS;
}
static void
resolve_equivalence (gfc_equiv *eq)
{
gfc_symbol *sym;
gfc_symbol *derived;
gfc_symbol *first_sym;
gfc_expr *e;
gfc_ref *r;
locus *last_where = NULL;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
int object;
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;
for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
e->ts = e->symtree->n.sym->ts;
if (e->ref && e->ref->type == REF_ARRAY)
{
gfc_ref *ref = e->ref;
sym = e->symtree->n.sym;
if (sym->attr.dimension)
{
ref->u.ar.as = sym->as;
ref = ref->next;
}
if (e->ts.type == BT_CHARACTER
&& ref
&& ref->type == REF_ARRAY
&& ref->u.ar.dimen == 1
&& ref->u.ar.dimen_type[0] == DIMEN_RANGE
&& ref->u.ar.stride[0] == NULL)
{
gfc_expr *start = ref->u.ar.start[0];
gfc_expr *end = ref->u.ar.end[0];
void *mem = NULL;
if (start == NULL && end == NULL)
{
if (e->ref == ref)
e->ref = ref->next;
else
e->ref->next = ref->next;
mem = ref;
}
else
{
ref->type = REF_SUBSTRING;
if (start == NULL)
start = gfc_int_expr (1);
ref->u.ss.start = start;
if (end == NULL && e->ts.cl)
end = gfc_copy_expr (e->ts.cl->length);
ref->u.ss.end = end;
ref->u.ss.length = e->ts.cl;
e->ts.cl = NULL;
}
ref = ref->next;
gfc_free (mem);
}
if (ref)
{
gcc_assert (ref->type == REF_ARRAY);
gfc_error ("Syntax error in EQUIVALENCE statement at %L",
&ref->u.ar.where);
continue;
}
}
if (gfc_resolve_expr (e) == FAILURE)
continue;
sym = e->symtree->n.sym;
if (sym->value)
{
if (value_name != NULL)
{
gfc_error ("Initialized objects '%s' and '%s' cannot both "
"be in the EQUIVALENCE statement at %L",
value_name, sym->name, &e->where);
continue;
}
else
value_name = sym->name;
}
if (sym->ns->proc_name
&& sym->ns->proc_name->attr.pure
&& sym->attr.in_common)
{
gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
"object in the pure procedure '%s'",
sym->name, &e->where, sym->ns->proc_name->name);
break;
}
if (e->expr_type == EXPR_CONSTANT)
{
gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
"object", sym->name, &e->where);
continue;
}
derived = e->ts.derived;
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
continue;
if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
goto identical_types;
last_eq_type = sequence_type (*last_ts);
eq_type = sequence_type (sym->ts);
msg = "Sequence %s with mixed components in EQUIVALENCE "
"statement at %L with different type objects";
if ((object ==2
&& last_eq_type == SEQ_MIXED
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
last_where) == FAILURE)
|| (eq_type == SEQ_MIXED
&& gfc_notify_std (GFC_STD_GNU, msg,sym->name,
&e->where) == FAILURE))
continue;
msg = "Non-default type object or sequence %s in EQUIVALENCE "
"statement at %L with objects of different type";
if ((object ==2
&& last_eq_type == SEQ_NONDEFAULT
&& gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
last_where) == FAILURE)
|| (eq_type == SEQ_NONDEFAULT
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
&e->where) == FAILURE))
continue;
msg ="Non-CHARACTER object '%s' in default CHARACTER "
"EQUIVALENCE statement at %L";
if (last_eq_type == SEQ_CHARACTER
&& eq_type != SEQ_CHARACTER
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
&e->where) == FAILURE)
continue;
msg ="Non-NUMERIC object '%s' in default NUMERIC "
"EQUIVALENCE statement at %L";
if (last_eq_type == SEQ_NUMERIC
&& eq_type != SEQ_NUMERIC
&& gfc_notify_std (GFC_STD_GNU, msg, sym->name,
&e->where) == FAILURE)
continue;
identical_types:
last_ts =&sym->ts;
last_where = &e->where;
if (!e->ref)
continue;
if (e->ref->type == REF_ARRAY
&& gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
{
gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
"an EQUIVALENCE object", sym->name, &e->where);
continue;
}
r = e->ref;
while (r)
{
if (r->type == REF_COMPONENT)
{
gfc_error ("Structure component '%s' at %L cannot be an "
"EQUIVALENCE object",
r->u.c.component->name, &e->where);
break;
}
if (r->type == REF_SUBSTRING)
{
if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
{
gfc_error ("Substring at %L has length zero",
&r->u.ss.start->where);
break;
}
}
r = r->next;
}
}
}
static void
resolve_fntype (gfc_namespace * ns)
{
gfc_entry_list *el;
gfc_symbol *sym;
if (ns->proc_name == NULL || !ns->proc_name->attr.function)
return;
if (ns->entries)
sym = ns->entries->sym;
else
sym = ns->proc_name;
if (sym->result == sym
&& sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (sym, 0, NULL) == FAILURE
&& !sym->attr.untyped)
{
gfc_error ("Function '%s' at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
sym->attr.untyped = 1;
}
if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
&& !gfc_check_access (sym->ts.derived->attr.access,
sym->ts.derived->ns->default_access)
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{
gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
sym->name, &sym->declared_at, sym->ts.derived->name);
}
if (sym->ts.type == BT_DERIVED
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->ts.derived->ns
&& sym->ns != sym->ts.derived->ns)
{
gfc_dt_list *dt = sym->ns->derived_types;
for (; dt; dt = dt->next)
if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
sym->ts.derived = dt->derived;
}
if (ns->entries)
for (el = ns->entries->next; el; el = el->next)
{
if (el->sym->result == el->sym
&& el->sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (el->sym, 0, NULL) == FAILURE
&& !el->sym->attr.untyped)
{
gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
el->sym->name, &el->sym->declared_at);
el->sym->attr.untyped = 1;
}
}
}
static void
gfc_resolve_uops(gfc_symtree *symtree)
{
gfc_interface *itr;
gfc_symbol *sym;
gfc_formal_arglist *formal;
if (symtree == NULL)
return;
gfc_resolve_uops (symtree->left);
gfc_resolve_uops (symtree->right);
for (itr = symtree->n.uop->operator; itr; itr = itr->next)
{
sym = itr->sym;
if (!sym->attr.function)
gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
sym->name, &sym->declared_at);
if (sym->ts.type == BT_CHARACTER
&& !(sym->ts.cl && sym->ts.cl->length)
&& !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
gfc_error("User operator procedure '%s' at %L cannot be assumed character "
"length", sym->name, &sym->declared_at);
formal = sym->formal;
if (!formal || !formal->sym)
{
gfc_error("User operator procedure '%s' at %L must have at least "
"one argument", sym->name, &sym->declared_at);
continue;
}
if (formal->sym->attr.intent != INTENT_IN)
gfc_error ("First argument of operator interface at %L must be "
"INTENT(IN)", &sym->declared_at);
if (formal->sym->attr.optional)
gfc_error ("First argument of operator interface at %L cannot be "
"optional", &sym->declared_at);
formal = formal->next;
if (!formal || !formal->sym)
continue;
if (formal->sym->attr.intent != INTENT_IN)
gfc_error ("Second argument of operator interface at %L must be "
"INTENT(IN)", &sym->declared_at);
if (formal->sym->attr.optional)
gfc_error ("Second argument of operator interface at %L cannot be "
"optional", &sym->declared_at);
if (formal->next)
gfc_error ("Operator interface at %L must have, at most, two "
"arguments", &sym->declared_at);
}
}
static void
resolve_types (gfc_namespace * ns)
{
gfc_namespace *n;
gfc_charlen *cl;
gfc_data *d;
gfc_equiv *eq;
gfc_current_ns = ns;
resolve_entries (ns);
resolve_contained_functions (ns);
gfc_traverse_ns (ns, resolve_symbol);
resolve_fntype (ns);
for (n = ns->contained; n; n = n->sibling)
{
if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
"also be PURE", n->proc_name->name,
&n->proc_name->declared_at);
resolve_types (n);
}
forall_flag = 0;
gfc_check_interfaces (ns);
for (cl = ns->cl_list; cl; cl = cl->next)
resolve_charlen (cl);
gfc_traverse_ns (ns, resolve_values);
if (ns->save_all)
gfc_save_all (ns);
iter_stack = NULL;
for (d = ns->data; d; d = d->next)
resolve_data (d);
iter_stack = NULL;
gfc_traverse_ns (ns, gfc_formalize_init_value);
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
if (warn_unused_label)
warn_unused_fortran_label (ns->st_labels);
gfc_resolve_uops (ns->uop_root);
}
static void
resolve_codes (gfc_namespace * ns)
{
gfc_namespace *n;
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);
gfc_current_ns = ns;
cs_base = NULL;
current_entry_id = -1;
resolve_code (ns->code, ns);
}
void
gfc_resolve (gfc_namespace * ns)
{
gfc_namespace *old_ns;
old_ns = gfc_current_ns;
resolve_types (ns);
resolve_codes (ns);
gfc_current_ns = old_ns;
}