/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+ Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "flags.h"
#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
+#include "dependency.h"
+/* Types used in equivalence statements. */
+
+typedef enum seq_type
+{
+ SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
+}
+seq_type;
/* Stack to push the current if we descend into a block during
resolution. See resolve_branch() and resolve_code(). */
static code_stack *cs_base = NULL;
-/* Nonzero if we're inside a FORALL block */
+/* Nonzero if we're inside a FORALL block. */
static int forall_flag;
+/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
+
+static int omp_workshare_flag;
+
+/* Nonzero if we are processing a formal arglist. The corresponding function
+ resets the flag each time that it is read. */
+static int formal_arg_flag = 0;
+
+/* True if we are resolving a specification expression. */
+static int specification_expr = 0;
+
+/* The id of the last entry seen. */
+static int current_entry_id;
+
+int
+gfc_is_formal_arg (void)
+{
+ return formal_arg_flag;
+}
+
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
gfc_symbol *sym;
int i;
- /* TODO: Procedures whose return character length parameter is not constant
- or assumed must also have explicit interfaces. */
if (proc->result != NULL)
sym = proc->result;
else
|| (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->attr.function || sym->result == sym)
gfc_set_default_type (sym, 1, sym->ns);
- else
- {
- /* Set the type of the RESULT, then copy. */
- if (sym->result->ts.type == BT_UNKNOWN)
- gfc_set_default_type (sym->result, 1, sym->result->ns);
-
- sym->ts = sym->result->ts;
- if (sym->as == NULL)
- sym->as = gfc_copy_array_spec (sym->result->as);
- }
}
gfc_resolve_array_spec (sym->as, 0);
{
gfc_error
("Character-valued argument '%s' of statement function at "
- "%L must has constant length",
+ "%L must have constant length",
sym->name, &sym->declared_at);
continue;
}
}
}
}
+ formal_arg_flag = 0;
}
resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
{
try t;
-
+
/* If this namespace is not a function, ignore it. */
if (! sym
|| !(sym->attr.function
sym->attr.untyped = 1;
}
}
+
+ /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
+ lists the only ways a character length value of * can be used: dummy arguments
+ of procedures, named constants, and function results in external functions.
+ Internal function results are not on that list; ergo, not permitted. */
+
+ 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);
+ }
}
for (; new_args != NULL; new_args = new_args->next)
{
new_sym = new_args->sym;
- /* See if ths arg is already in the formal argument list. */
+ /* See if this arg is already in the formal argument list. */
for (f = proc->formal; f; f = f->next)
{
if (new_sym == f->sym)
/* If this isn't a procedure something has gone horribly wrong. */
gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
-
+
/* Remember the current namespace. */
old_ns = gfc_current_ns;
ns->entries = el;
ns->proc_name->attr.entry = 1;
+ /* If it is a module function, it needs to be in the right namespace
+ so that gfc_get_fake_result_decl can gather up the results. The
+ need for this arose in get_proc_name, where these beasts were
+ left in their own namespace, to keep prior references linked to
+ the entry declaration.*/
+ if (ns->proc_name->attr.function
+ && ns->parent
+ && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ el->sym->ns = ns;
+
/* Add an entry statement for it. */
c = gfc_get_code ();
c->op = EXEC_ENTRY;
{
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 = el->sym->result;
if (sym->attr.dimension)
- gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
- el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
- ns->entries->sym->name, &sym->declared_at);
+ {
+ 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)
- gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
- el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
- ns->entries->sym->name, &sym->declared_at);
+ {
+ 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;
break;
}
if (sym)
- gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
- el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
- gfc_typename (ts), ns->entries->sym->name,
- &sym->declared_at);
+ {
+ 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);
+ }
}
}
}
for (child = ns->contained; child; child = child->sibling)
{
/* Resolve alternate entry points first. */
- resolve_entries (child);
+ resolve_entries (child);
/* Then check function return types. */
resolve_contained_fntype (child->proc_name, child);
gfc_constructor *cons;
gfc_component *comp;
try t;
+ symbol_attribute a;
t = SUCCESS;
cons = expr->value.constructor;
for (; comp; comp = comp->next, cons = cons->next)
{
if (! cons->expr)
+ continue;
+
+ if (gfc_resolve_expr (cons->expr) == FAILURE)
{
t = FAILURE;
continue;
}
- if (gfc_resolve_expr (cons->expr) == FAILURE)
+ 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;
- continue;
}
/* If we don't have the right type, try to convert it. */
- if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
- && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
- 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;
return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
- || a.optional || a.pointer || a.save || a.target
+ || a.optional || a.pointer || a.save || a.target || a.volatile_
|| a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
return PTYPE_UNKNOWN;
}
+/* Check references to assumed size arrays. The flag need_full_assumed_size
+ is nonzero when matching actual arguments. */
+
+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;
+}
+
+
+/* Look for bad assumed size array references in argument expressions
+ of elemental and array valued intrinsic procedures. Since this is
+ called from procedure resolution functions, it only recurses at
+ operators. */
+
+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;
+}
+
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
|| sym->attr.intrinsic
|| sym->attr.external)
{
+ int actual_ok;
- 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);
- }
+ /* If a procedure is not already determined to be something else
+ check if it is intrinsic. */
+ 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);
+ }
+ else if (sym->attr.intrinsic && actual_ok == 2)
+ /* We need a special case for CHAR, which is the only intrinsic
+ function allowed as actual argument in F2003 and not allowed
+ in F95. */
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CHAR intrinsic "
+ "as actual argument at %L", &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 the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
}
+/* Do the checks of the actual argument list that are specific to elemental
+ procedures. If called with c == NULL, we have a function, otherwise if
+ expr == NULL, we have a subroutine. */
+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;
+
+ /* Is this an elemental procedure? */
+ 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;
+
+ /* The rank of an elemental is the rank of its array argument(s). */
+ 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;
+
+ /* Function specific; set the result rank and shape. */
+ 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;
+ }
+ }
+
+ /* If it is an array, it shall not be supplied as an actual argument
+ to an elemental procedure unless an array of the same rank is supplied
+ as an actual argument corresponding to a nonoptional dummy argument of
+ that elemental procedure(12.4.1.5). */
+ 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;
+
+ /* Being elemental, the last upper bound of an assumed size array
+ argument must be present. */
+ if (resolve_assumed_size_actual (arg->expr))
+ return FAILURE;
+
+ if (expr)
+ continue;
+
+ /* Elemental subroutine array actual arguments must conform. */
+ if (e != NULL)
+ {
+ if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
+ == FAILURE)
+ return FAILURE;
+ }
+ else
+ e = arg->expr;
+ }
+
+ return SUCCESS;
+}
+
+
+/* Go through each actual argument in ACTUAL and see if it can be
+ implemented as an inlined, non-copying intrinsic. FNSYM is the
+ function being called, or NULL if not known. */
+
+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;
+}
+
+/* This function does the checking of references to global procedures
+ as defined in sections 18.1 and 14.1, respectively, of the Fortran
+ 77 and 95 standards. It checks for a gsymbol for the name, making
+ one if it does not already exist. If it already exists, then the
+ reference being resolved must correspond to the type of gsymbol.
+ Otherwise, the new symbol is equipped with the attributes of the
+ reference. The corresponding code that is called in creating
+ global entities is parse.c. */
+
+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;
+}
+
/************* Function resolution *************/
/* Resolve a function call known to be generic.
{
expr->value.function.name = s->name;
expr->value.function.esym = s;
- expr->ts = s->ts;
+
+ 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 (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
{
- gfc_error ("Generic function '%s' at %L is not an intrinsic function",
+ gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
resolve_function (gfc_expr * expr)
{
gfc_actual_arglist *arg;
+ gfc_symbol * sym;
const char *name;
try t;
+ int temp;
+
+ sym = NULL;
+ if (expr->symtree)
+ sym = expr->symtree->n.sym;
+
+ /* If the procedure is not internal, a statement function or a module
+ procedure,it must be external and should be checked for usage. */
+ 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);
+
+ /* Switch off assumed size checking and do this again for certain kinds
+ of procedure, once the procedure itself is resolved. */
+ need_full_assumed_size++;
if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
return FAILURE;
+ /* Resume assumed_size checking. */
+ 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)
+ {
+ /* Internal procedures are taken care of in resolve_contained_fntype. */
+ 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;
+ }
+
/* See if function is already resolved. */
if (expr->value.function.name != NULL)
{
if (expr->ts.type == BT_UNKNOWN)
- expr->ts = expr->symtree->n.sym->ts;
+ expr->ts = sym->ts;
t = SUCCESS;
}
else
{
/* Apply the rules of section 14.1.2. */
- switch (procedure_kind (expr->symtree->n.sym))
+ switch (procedure_kind (sym))
{
case PTYPE_GENERIC:
t = resolve_generic_f (expr);
if (expr->expr_type != EXPR_FUNCTION)
return t;
- if (expr->value.function.actual != NULL
- && ((expr->value.function.esym != NULL
- && expr->value.function.esym->attr.elemental)
- || (expr->value.function.isym != NULL
- && expr->value.function.isym->elemental)))
+ 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;
+ }
- /* The rank of an elemental is the rank of its array argument(s). */
+ else if (expr->value.function.actual != NULL
+ && expr->value.function.isym != NULL
+ && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
+ && expr->value.function.isym->generic_id != GFC_ISYM_LOC
+ && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
+ {
+ /* Array intrinsics must also have the last upper bound of an
+ assumed size array argument. UBOUND and SIZE have to be
+ excluded from the check if the second argument is anything
+ than a constant. */
+ int inquiry;
+ inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
+ || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;
for (arg = expr->value.function.actual; arg; arg = arg->next)
{
- if (arg->expr != NULL && arg->expr->rank > 0)
- {
- expr->rank = arg->expr->rank;
- break;
- }
+ if (inquiry && arg->next != NULL && arg->next->expr
+ && arg->next->expr->expr_type != EXPR_CONSTANT)
+ break;
+
+ if (arg->expr != NULL
+ && arg->expr->rank > 0
+ && resolve_assumed_size_actual (arg->expr))
+ return FAILURE;
}
}
- if (!pure_function (expr, &name))
+ need_full_assumed_size = temp;
+
+ if (!pure_function (expr, &name) && name)
{
if (forall_flag)
{
gfc_error
- ("Function reference to '%s' at %L is inside a FORALL block",
- name, &expr->where);
+ ("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))
}
}
+ /* Functions without the RECURSIVE attribution are not allowed to
+ * call themselves. */
+ 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;
+ }
+ }
+
+ /* Character lengths of use associated functions may contains references to
+ symbols not referenced from the current program unit otherwise. Make sure
+ those symbols are marked as referenced. */
+
+ 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);
return t;
}
sym = c->symtree->n.sym;
- m = resolve_generic_s0 (c, sym);
- if (m == MATCH_YES)
- return SUCCESS;
- if (m == MATCH_ERROR)
- return FAILURE;
-
- if (sym->ns->parent != NULL)
+ 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)
- {
- m = resolve_generic_s0 (c, sym);
- if (m == MATCH_YES)
- return SUCCESS;
- if (m == MATCH_ERROR)
- return FAILURE;
- }
+
+ if (sym == NULL)
+ break;
+ if (!generic_sym (sym))
+ goto generic;
}
/* Last ditch attempt. */
-
+ sym = c->symtree->n.sym;
if (!gfc_generic_intrinsic (sym->name))
{
gfc_error
- ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
+ ("There is no specific subroutine for the generic '%s' at %L",
sym->name, &c->loc);
return FAILURE;
}
sym = c->symtree->n.sym;
- m = resolve_specific_s0 (c, sym);
- if (m == MATCH_YES)
- return SUCCESS;
- if (m == MATCH_ERROR)
- return FAILURE;
-
- gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
-
- if (sym != NULL)
+ 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);
{
try t;
+ 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 the procedure is not internal or module, it must be external and
+ should be checked for usage. */
+ 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);
+
+ /* Subroutines without the RECURSIVE attribution are not allowed to
+ * call themselves. */
+ 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;
+ }
+ }
+
+ /* Switch off assumed size checking and do this again for certain kinds
+ of procedure, once the procedure itself is resolved. */
+ need_full_assumed_size++;
+
if (resolve_actual_arglist (c->ext.actual) == FAILURE)
return FAILURE;
- if (c->resolved_sym != NULL)
- return SUCCESS;
+ /* Resume assumed_size checking. */
+ need_full_assumed_size--;
- 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;
+ 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_UNKNOWN:
- t = resolve_unknown_s (c);
- break;
+ case PTYPE_SPECIFIC:
+ t = resolve_specific_s (c);
+ break;
- default:
- gfc_internal_error ("resolve_subroutine(): bad function type");
- }
+ case PTYPE_UNKNOWN:
+ t = resolve_unknown_s (c);
+ break;
+
+ default:
+ gfc_internal_error ("resolve_subroutine(): bad function type");
+ }
+
+ /* Some checks of elemental subroutine actual arguments. */
+ if (resolve_elemental_actual (NULL, c) == FAILURE)
+ return FAILURE;
+ if (t == SUCCESS)
+ find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
int i;
t = SUCCESS;
-
+
if (op1->shape != NULL && op2->shape != NULL)
{
for (i = 0; i < op1->rank; i++)
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
break;
}
- sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
+ 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;
}
sprintf (msg,
- "Operands of binary numeric operator '%s' at %%L are %s/%s",
+ _("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;
}
sprintf (msg,
- "Operands of string concatenation operator at %%L are %s/%s",
+ _("Operands of string concatenation operator at %%L are %s/%s"),
gfc_typename (&op1->ts), gfc_typename (&op2->ts));
goto bad_op;
break;
}
- sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
+ 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));
break;
}
- sprintf (msg, "Operand of .NOT. operator at %%L is %s",
+ sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
gfc_typename (&op1->ts));
goto bad_op;
case INTRINSIC_LE:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
- strcpy (msg, "COMPLEX quantities cannot be compared at %L");
+ strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
goto bad_op;
}
}
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
- sprintf (msg, "Logicals at %%L must be compared with %s instead of %s",
+ 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",
+ 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));
case INTRINSIC_USER:
if (op2 == NULL)
- sprintf (msg, "Operand of user operator '%s' at %%L is %s",
+ 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",
+ 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");
}
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
e->rank = op1->rank;
if (e->shape == NULL)
}
+/* Compare an integer expression with a mpz_t. */
+
+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;
+}
+
+
+/* Compute the last value of a sequence given by a triplet.
+ Return 0 if it wasn't able to compute the last value, or if the
+ sequence if empty, and 1 otherwise. */
+
+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)
+ {
+ /* Stride is positive */
+ if (mpz_cmp (start->value.integer, end->value.integer) > 0)
+ return 0;
+ }
+ else
+ {
+ /* Stride is negative */
+ 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;
+}
+
+
/* Compare a single dimension of an array reference to the array
specification. */
static try
check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
{
+ mpz_t last_value;
/* Given start, end and stride values, calculate the minimum and
maximum referenced indexes. */
return FAILURE;
}
- if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
- goto bound;
- if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
+#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;
- /* TODO: Possibly, we could warn about end[i] being out-of-bound although
- it is legal (see 6.2.2.3.1). */
+ 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;
}
if (index->ts.type == BT_REAL)
- if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
+ 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_error ("Argument dim at %L must be scalar", &dim->where);
return FAILURE;
-
+
}
if (dim->ts.type != BT_INTEGER)
{
{
gfc_array_spec *as;
gfc_component *c;
+ gfc_symbol *derived;
gfc_ref *ref;
as = e->symtree->n.sym->as;
- c = e->symtree->n.sym->components;
+ derived = NULL;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
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)
- break;
+ {
+ /* Track the sequence of component references. */
+ if (c->ts.type == BT_DERIVED)
+ derived = c->ts.derived;
+ break;
+ }
if (c == NULL)
gfc_internal_error ("find_array_spec(): Component not found");
as = c->as;
}
- c = c->ts.derived->components;
break;
case REF_SUBSTRING:
resolve_array_ref (gfc_array_ref * ar)
{
int i, check_scalar;
+ gfc_expr *e;
for (i = 0; i < ar->dimen; i++)
{
if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
return FAILURE;
+ e = ar->start[i];
+
if (ar->dimen_type[i] == DIMEN_UNKNOWN)
- switch (ar->start[i]->rank)
+ switch (e->rank)
{
case 0:
ar->dimen_type[i] = DIMEN_ELEMENT;
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], ar->start[i]->rank);
+ &ar->c_where[i], e->rank);
return FAILURE;
}
}
}
}
- if (compare_spec_to_ref (ar) == FAILURE)
+ if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
return FAILURE;
return SUCCESS;
return FAILURE;
}
- if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
+ 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);
}
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.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 is out of bounds",
+ gfc_error ("Substring end index at %L exceeds the string length",
&ref->u.ss.start->where);
return FAILURE;
}
break;
case REF_COMPONENT:
- if ((current_part_dimension || seen_part_dimension)
- && ref->u.c.component->pointer)
+ if (current_part_dimension || seen_part_dimension)
{
- 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;
+ 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++;
resolve_variable (gfc_expr * e)
{
gfc_symbol *sym;
+ try t;
- if (e->ref && resolve_ref (e) == FAILURE)
- return FAILURE;
+ 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)
{
else
{
/* Must be a simple variable reference. */
- if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
+ if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
return FAILURE;
e->ts = sym->ts;
}
- return SUCCESS;
+ if (check_assumed_size_reference (sym, e))
+ return FAILURE;
+
+ /* Deal with forward references to entries during resolve_code, to
+ satisfy, at least partially, 12.5.2.5. */
+ 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 the symbol is a dummy... */
+ if (sym->attr.dummy)
+ {
+ entry = gfc_current_ns->entries;
+ seen = false;
+
+ /* ...test if the symbol is a parameter of previous entries. */
+ 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 it has not been seen as a dummy, this is an error. */
+ 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;
+ }
+ }
+
+ /* Now do the same check on the specification expressions. */
+ 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)
+ /* Update the symbol's entry level. */
+ sym->entry_id = current_entry_id + 1;
+ }
+
+ return t;
}
gfc_expand_constructor (e);
}
+ /* This provides the opportunity for the length of constructors with character
+ valued function elements to propogate the string length to the expression. */
+ if (e->ts.type == BT_CHARACTER)
+ gfc_resolve_character_array_constructor (e);
+
break;
case EXPR_STRUCTURE:
INTEGER or (optionally) REAL type. */
static try
-gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, const char * name)
+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, &expr->where);
+ 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)))
{
- gfc_error ("%s at %L must be INTEGER%s",
- name,
- &expr->where,
- real_ok ? " or REAL" : "");
+ 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;
}
-/* Resolve a list of FORALL iterators. */
+/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
+ to be a scalar INTEGER variable. The subscripts and stride are scalar
+ INTEGERs, and if stride is a constant it must be nonzero. */
static void
resolve_forall_iterators (gfc_forall_iterator * iter)
while (iter)
{
if (gfc_resolve_expr (iter->var) == SUCCESS
- && iter->var->ts.type != BT_INTEGER)
- gfc_error ("FORALL Iteration variable at %L must be INTEGER",
+ && (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)
- gfc_error ("FORALL start expression at %L must be INTEGER",
+ && (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)
- gfc_error ("FORALL end expression at %L must be INTEGER",
+ && (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
- && iter->stride->ts.type != BT_INTEGER)
- gfc_error ("FORALL Stride expression at %L must be INTEGER",
- &iter->stride->where);
+ 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);
}
+/* Given a pointer to a symbol that is a derived type, see if it's
+ inaccessible, i.e. if it's defined in another module and the components are
+ PRIVATE. The search is recursive if necessary. Returns zero if no
+ inaccessible components are found, nonzero otherwise. */
+
+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;
+}
+
+
/* Resolve the argument of a deallocate expression. The expression must be
a pointer or a full array. */
"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;
}
+/* Returns true if the expression e contains a reference the symbol sym. */
+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;
+
+ /* If the variable is not the same as the dependent, 'sym', and
+ it is not marked as being declared and it is in the same
+ namespace as 'sym', add it to the local declarations. */
+ 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;
+}
+
+
+/* Given the expression node e for an allocatable/pointer of derived type to be
+ allocated, get the expression node to be initialized afterwards (needed for
+ derived types with default initializers, and derived types with allocatable
+ components that need nullification.) */
+
+static gfc_expr *
+expr_to_initialize (gfc_expr * e)
+{
+ gfc_expr *result;
+ gfc_ref *ref;
+ int i;
+
+ result = gfc_copy_expr (e);
+
+ /* Change the last array reference from AR_ELEMENT to AR_FULL. */
+ 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;
+}
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
static try
-resolve_allocate_expr (gfc_expr * e)
+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;
+
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
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)
{
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;
+ }
+
+ /* Add default initializer for those derived types that need them. */
+ 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;
return FAILURE;
}
- if (ref2->u.ar.type == AR_ELEMENT)
- return SUCCESS;
-
/* Make sure that the array section reference makes sense in the
context of an ALLOCATE specification. */
ar = &ref2->u.ar;
for (i = 0; i < ar->dimen; i++)
- switch (ar->dimen_type[i])
- {
- case DIMEN_ELEMENT:
- break;
+ {
+ if (ref2->u.ar.type == AR_ELEMENT)
+ goto check_symbols;
- case DIMEN_RANGE:
- if (ar->start[i] != NULL
- && ar->end[i] != NULL
- && ar->stride[i] == NULL)
+ switch (ar->dimen_type[i])
+ {
+ case DIMEN_ELEMENT:
break;
- /* Fall Through... */
+ 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;
- }
+ /* Fall Through... */
+
+ 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;
+
+ /* TODO - check derived type components. */
+ 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;
}
gfc_expr *case_expr;
gfc_case *cp, *default_case, *tail, *head;
int seen_unreachable;
+ int seen_logical;
int ncases;
bt type;
try t;
if (cp->low == NULL && cp->high == NULL)
continue;
- /* Unreachable case ranges are discarded, so ignore. */
+ /* Unreachable case ranges are discarded, so ignore. */
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
&& gfc_compare_expr (cp->low, cp->high) > 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);
+ 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)
{
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)
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
- -- a derived type being transferred doesn't have private components
+ -- a derived type being transferred doesn't have private components, unless
+ it's being transferred from the module where the type was defined
-- we're not trying to transfer a whole assumed size array. */
static void
exp = code->expr;
- if (exp->expr_type != EXPR_VARIABLE)
+ if (exp->expr_type != EXPR_VARIABLE
+ && exp->expr_type != EXPR_FUNCTION)
return;
sym = exp->symtree->n.sym;
return;
}
- if (ts->derived->component_access == ACCESS_PRIVATE)
+ 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);
if (found == NULL)
{
- /* still nothing, so illegal. */
- gfc_error_now ("Label at %L is not in the same block as the "
- "GOTO statement at %L", &lp->where, &code->loc);
+ /* The label is not in an enclosing block, so illegal. This was
+ allowed in Fortran 66, so we allow it as extension. We also
+ forego further checks if we run into this. */
+ 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;
}
break;
default:
- gfc_error("expresion reference type error at %L", &expr->where);
+ gfc_error("expression reference type error at %L", &expr->where);
}
tmp = tmp->next;
}
gfc_resolve_assign_in_forall (c, nvar, var_expr);
break;
- /* Because the resolve_blocks() will handle the nested FORALL,
+ /* Because the gfc_resolve_blocks() will handle the nested FORALL,
there is no need to handle it here. */
case EXEC_FORALL:
break;
/* Given a FORALL construct, first resolve the FORALL iterator, then call
gfc_resolve_forall_body to resolve the FORALL body. */
-static void resolve_blocks (gfc_code *, gfc_namespace *);
-
static void
gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
{
gfc_resolve_forall_body (code, nvar, var_expr);
/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
- resolve_blocks (code->block, ns);
+ gfc_resolve_blocks (code->block, ns);
/* Free VAR_EXPR after the whole FORALL construct resolved. */
for (i = 0; i < total_var; i++)
static void resolve_code (gfc_code *, gfc_namespace *);
-static void
-resolve_blocks (gfc_code * b, gfc_namespace * ns)
+void
+gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
{
try t;
if (t == SUCCESS && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
gfc_error
- ("ELSE IF clause at %L requires a scalar LOGICAL expression",
+ ("IF clause at %L requires a scalar LOGICAL expression",
&b->expr->where);
break;
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:
static void
resolve_code (gfc_code * code, gfc_namespace * ns)
{
- int forall_save = 0;
+ int omp_workshare_save;
+ int forall_save;
code_stack frame;
gfc_alloc *a;
try t;
for (; code; code = code->next)
{
frame.current = code;
+ forall_save = forall_flag;
if (code->op == EXEC_FORALL)
{
- forall_save = forall_flag;
forall_flag = 1;
- gfc_resolve_forall (code, ns, forall_save);
- }
- else
- resolve_blocks (code->block, ns);
+ 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;
+ /* FALLTHROUGH */
+ default:
+ gfc_resolve_blocks (code->block, ns);
+ break;
+ }
- if (code->op == EXEC_FORALL)
- forall_flag = forall_save;
+ 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;
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
+ break;
+
case EXEC_ENTRY:
+ /* Keep track of which entry we are up to. */
+ current_entry_id = code->ext.entry->id;
break;
case EXEC_WHERE:
break;
case EXEC_RETURN:
- if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
- gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
- "return specifier", &code->expr->where);
+ 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:
break;
if (gfc_extend_assign (code, ns) == SUCCESS)
- goto call;
+ {
+ 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 (gfc_pure (NULL))
{
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
+ || 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 "
case EXEC_DO:
if (code->ext.iterator != NULL)
- gfc_resolve_iterator (code->ext.iterator, true);
+ {
+ 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:
"of type INTEGER", &code->expr->where);
for (a = code->ext.alloc_list; a; a = a->next)
- resolve_allocate_expr (a->expr);
+ resolve_allocate_expr (a->expr, code);
break;
&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");
}
}
-/* Do anything necessary to resolve a symbol. Right now, we just
- assume that an otherwise unknown symbol is a variable. This sort
- of thing commonly happens for symbols in module. */
+/* Resolve an index expression. */
-static void
-resolve_symbol (gfc_symbol * sym)
+static try
+resolve_index_expr (gfc_expr * e)
{
- /* Zero if we are checking a formal namespace. */
- static int formal_ns_flag = 1;
- int formal_ns_save, check_constant, mp_flag;
- int i;
- const char *whynot;
- gfc_namelist *nl;
- gfc_symtree * symtree;
- gfc_symtree * this_symtree;
- gfc_namespace * ns;
+ if (gfc_resolve_expr (e) == FAILURE)
+ return FAILURE;
- if (sym->attr.flavor == FL_UNKNOWN)
+ if (gfc_simplify_expr (e, 0) == FAILURE)
+ return FAILURE;
+
+ if (gfc_specification_expr (e) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+/* Resolve a charlen structure. */
+
+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;
+ }
- /* If we find that a flavorless symbol is an interface in one of the
- parent namespaces, find its symtree in this namespace, free the
- symbol and set the symtree to point to the interface symbol. */
- 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;
- }
- }
+ return SUCCESS;
+}
- /* Otherwise give it a flavor according to such attributes as
- it has. */
- if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
- sym->attr.flavor = FL_VARIABLE;
- else
+
+/* Test for non-constant shape arrays. */
+
+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)
+ {
+ /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
+ has not been simplified; parameter array references. Do the
+ simplification now. */
+ for (i = 0; i < sym->as->rank; i++)
{
- sym->attr.flavor = FL_PROCEDURE;
- if (sym->attr.dimension)
- sym->attr.function = 1;
+ 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;
+}
- /* Symbols that are module procedures with results (functions) have
- the types and array specification copied for type checking in
- procedures that call them, as well as for saving to a module
- file. These symbols can't stand the scrutiny that their results
- can. */
- mp_flag = (sym->result != NULL && sym->result != sym);
- /* Assign default type to symbols that need one and don't have one. */
- if (sym->ts.type == BT_UNKNOWN)
- {
- if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
- gfc_set_default_type (sym, 1, NULL);
+/* Assign the default initializer to a derived type variable or result. */
- if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
- {
- if (!mp_flag)
- gfc_set_default_type (sym, 0, NULL);
- else
- {
- /* Result may be in another namespace. */
- resolve_symbol (sym->result);
+static void
+apply_default_init (gfc_symbol *sym)
+{
+ gfc_expr *lval;
+ gfc_expr *init = NULL;
+ gfc_code *init_st;
+ gfc_namespace *ns = sym->ns;
- 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;
- }
- }
- }
+ if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+ return;
- /* Assumed size arrays and assumed shape arrays must be dummy
- arguments. */
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived)
+ init = gfc_default_initializer (&sym->ts);
- if (sym->as != NULL
- && (sym->as->type == AS_ASSUMED_SIZE
- || sym->as->type == AS_ASSUMED_SHAPE)
- && sym->attr.dummy == 0)
+ if (init == NULL)
+ return;
+
+ /* Search for the function namespace if this is a contained
+ function without an explicit result. */
+ if (sym->attr.function && sym == sym->result
+ && sym->name != sym->ns->proc_name->name)
{
- gfc_error ("Assumed %s array at %L must be a dummy argument",
- sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
- &sym->declared_at);
- return;
+ ns = ns->contained;
+ for (;ns; ns = ns->sibling)
+ if (strcmp (ns->proc_name->name, sym->name) == 0)
+ break;
}
- /* A parameter array's shape needs to be constant. */
-
- if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
- && !gfc_is_compile_time_shape (sym->as))
+ if (ns == NULL)
{
- gfc_error ("Parameter array '%s' at %L cannot be automatic "
- "or assumed shape", sym->name, &sym->declared_at);
- return;
+ gfc_free_expr (init);
+ return;
}
- /* Make sure that character string variables with assumed length are
- dummy arguments. */
+ /* Build an l-value expression for the result. */
+ 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);
- if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
- && sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
+ /* It will always be a full array. */
+ lval->rank = sym->as ? sym->as->rank : 0;
+ if (lval->rank)
{
- gfc_error ("Entity with assumed character length at %L must be a "
- "dummy argument or a PARAMETER", &sym->declared_at);
- return;
+ 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;
}
- /* Make sure a parameter that has been implicitly typed still
- matches the implicit type, since PARAMETER statements can precede
- IMPLICIT statements. */
+ /* Add the code at scope entry. */
+ init_st = gfc_get_code ();
+ init_st->next = ns->code;
+ ns->code = init_st;
- if (sym->attr.flavor == FL_PARAMETER
- && 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);
+ /* Assign the default initializer to the l-value. */
+ init_st->loc = sym->declared_at;
+ init_st->op = EXEC_INIT_ASSIGN;
+ init_st->expr = lval;
+ init_st->expr2 = init;
+}
- /* Make sure the types of derived parameters are consistent. This
- type checking is deferred until resolution because the type may
- refer to a derived type from the host. */
- if (sym->attr.flavor == FL_PARAMETER
- && 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);
+/* Resolution of common features of flavors variable and procedure. */
- /* Make sure symbols with known intent or optional are really dummy
- variable. Because of ENTRY statement, this has to be deferred
- until resolution time. */
+static try
+resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
+{
+ /* Constraints on deferred shape variable. */
+ 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.dummy
- && (sym->attr.optional
- || sym->attr.intent != INTENT_UNKNOWN))
+ 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
{
- gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
- return;
+ 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;
+}
+
+/* Resolve symbols with flavor variable. */
+
+static try
+resolve_fl_variable (gfc_symbol *sym, int mp_flag)
+{
+ int flag;
+ int i;
+ gfc_expr *e;
+ gfc_expr *constructor_expr;
+ 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;
- if (sym->attr.proc == PROC_ST_FUNCTION)
+ /* Set this flag to check that variables are parameters of all entries.
+ This check is effected by the call to gfc_resolve_expr through
+ is_non_constant_shape_array. */
+ specification_expr = 1;
+
+ if (!sym->attr.use_assoc
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && is_non_constant_shape_array (sym))
{
- 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 statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return;
- }
- }
+ /* The shape of a main program or module array needs to be constant. */
+ 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;
+ }
}
- /* Constraints on deferred shape variable. */
- if (sym->attr.flavor == FL_VARIABLE
- || (sym->attr.flavor == FL_PROCEDURE
- && sym->attr.function))
+ if (sym->ts.type == BT_CHARACTER)
{
- if (sym->as == NULL || sym->as->type != AS_DEFERRED)
+ /* Make sure that character string variables with assumed length are
+ dummy arguments. */
+ e = sym->ts.cl->length;
+ if (e == NULL && !sym->attr.dummy && !sym->attr.result)
{
- if (sym->attr.allocatable)
- {
- if (sym->attr.dimension)
- gfc_error ("Allocatable array at %L must have a deferred shape",
- &sym->declared_at);
- else
- gfc_error ("Object at %L may not be ALLOCATABLE",
- &sym->declared_at);
- return;
- }
-
- if (sym->attr.pointer && sym->attr.dimension)
- {
- gfc_error ("Pointer to array at %L must have a deferred shape",
- &sym->declared_at);
- return;
- }
+ 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;
}
- else
+
+ 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)
{
- if (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
- {
- gfc_error ("Array at %L cannot have a deferred shape",
- &sym->declared_at);
- return;
- }
+ gfc_error ("'%s' at %L must have constant character length "
+ "in this context", sym->name, &sym->declared_at);
+ return FAILURE;
}
}
- switch (sym->attr.flavor)
+ /* Can the symbol have an initializer? */
+ 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)
{
- case FL_VARIABLE:
- /* Can the sybol have an initializer? */
- whynot = NULL;
- if (sym->attr.allocatable)
- whynot = "Allocatable";
- else if (sym->attr.external)
- whynot = "External";
- else if (sym->attr.dummy)
- whynot = "Dummy";
- else if (sym->attr.intrinsic)
- whynot = "Intrinsic";
- else if (sym->attr.result)
- whynot = "Function Result";
- else if (sym->attr.dimension && !sym->attr.pointer)
+ /* Don't allow initialization of automatic arrays. */
+ for (i = 0; i < sym->as->rank; i++)
{
- /* Don't allow initialization of automatic arrays. */
- 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)
{
- 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)
- {
- whynot = "Automatic array";
- break;
- }
+ flag = 1;
+ break;
}
}
- /* Reject illegal initializers. */
- if (sym->value && whynot)
+ /* Also, they must not have the SAVE attribute. */
+ if (flag && sym->attr.save)
{
- gfc_error ("%s '%s' at %L cannot have an initializer",
- whynot, sym->name, &sym->declared_at);
- return;
+ gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+ return FAILURE;
}
+ }
- /* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
- sym->value = gfc_default_initializer (&sym->ts);
- break;
-
- case FL_NAMELIST:
- /* Reject PRIVATE objects in a PUBLIC namelist. */
- if (gfc_check_access(sym->attr.access, sym->ns->default_access))
- {
- for (nl = sym->namelist; nl; nl = nl->next)
- {
- if (!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);
- }
+ /* Reject illegal initializers. */
+ 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;
+ }
+
+ /* Check to see if a derived type is blocked from being host associated
+ by the presence of another class I symbol in the same namespace.
+ 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
+ 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;
}
+ }
+
+ /* 4th constraint in section 11.3: "If an object of a type for which
+ component-initialization is specified (R429) appears in the
+ specification-part of a module and does not have the ALLOCATABLE
+ or POINTER attribute, the object shall have the SAVE attribute." */
+
+ constructor_expr = NULL;
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
+ constructor_expr = gfc_default_initializer (&sym->ts);
+
+ if (sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && constructor_expr
+ && !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;
+ }
+
+ /* Assign default initializer. */
+ 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;
+}
+
+
+/* Resolve a procedure. */
+
+static try
+resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
+{
+ gfc_formal_arglist *arg;
+
+ 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 || 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;
+ }
+ }
+ }
+
+ /* Ensure that derived type for are not of a private type. Internal
+ module procedures are excluded by 2.2.3.3 - ie. they are not
+ externally accessible and can access all the objects accessible in
+ the host. */
+ 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);
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return FAILURE;
+ }
+ }
+ }
+
+ /* An external symbol may not have an initializer because it is taken to be
+ a procedure. */
+ 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;
+ }
+
+ /* An elemental function is required to return a scalar 12.7.1 */
+ 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);
+ /* Reset so that the error only occurs once. */
+ sym->attr.elemental = 0;
+ return FAILURE;
+ }
+
+ /* 5.1.1.5 of the Standard: A function name declared with an asterisk
+ char-len-param shall not be array-valued, pointer-valued, recursive
+ or pure. ....snip... A character value of * may only be used in the
+ following ways: (i) Dummy arg of procedure - dummy associates with
+ actual length; (ii) To declare a named constant; or (iii) External
+ function - but length must be declared in calling scoping unit. */
+ 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;
+ }
+
+ /* Appendix B.2 of the standard. Contained functions give an
+ error anyway. Fixed-form is likely to be F77/legacy. */
+ 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;
+}
+
+
+/* Resolve the components of a derived type. */
+
+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;
+ }
+ }
+ }
+
+ /* Add derived type to the derived type list. */
+ 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;
+
+ /* Reject PRIVATE objects in a PUBLIC namelist. */
+ 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;
+ }
+ }
+ }
+
+ /* Reject namelist arrays that are not constant shape. */
+ 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;
+ }
+ }
+
+ /* Namelist objects cannot have allocatable components. */
+ 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;
+ }
+ }
+
+ /* 14.1.2 A module or internal procedure represent local entities
+ of the same type as a namelist member and so are not allowed.
+ Note that this is sometimes caught by check_conflict so the
+ same message has been used. */
+ 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)
+{
+ /* A parameter array's shape needs to be constant. */
+ 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;
+ }
+
+ /* Make sure a parameter that has been implicitly typed still
+ matches the implicit type, since PARAMETER statements can precede
+ IMPLICIT statements. */
+ 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;
+ }
+
+ /* Make sure the types of derived parameters are consistent. This
+ type checking is deferred until resolution because the type may
+ refer to a derived type from the host. */
+ 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;
+}
+
+
+/* Do anything necessary to resolve a symbol. Right now, we just
+ assume that an otherwise unknown symbol is a variable. This sort
+ of thing commonly happens for symbols in module. */
+
+static void
+resolve_symbol (gfc_symbol * sym)
+{
+ /* Zero if we are checking a formal namespace. */
+ 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)
+ {
+
+ /* If we find that a flavorless symbol is an interface in one of the
+ parent namespaces, find its symtree in this namespace, free the
+ symbol and set the symtree to point to the interface symbol. */
+ 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;
+ }
+ }
+
+ /* Otherwise give it a flavor according to such attributes as
+ it has. */
+ 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;
+
+ /* Symbols that are module procedures with results (functions) have
+ the types and array specification copied for type checking in
+ procedures that call them, as well as for saving to a module
+ file. These symbols can't stand the scrutiny that their results
+ can. */
+ mp_flag = (sym->result != NULL && sym->result != sym);
+
+ /* Assign default type to symbols that need one and don't have one. */
+ 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)
+ {
+ /* The specific case of an external procedure should emit an error
+ in the case that there is no implicit type. */
+ if (!mp_flag)
+ gfc_set_default_type (sym, sym->attr.external, NULL);
+ else
+ {
+ /* Result may be in another namespace. */
+ 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;
+ }
+ }
+ }
+
+ /* Assumed size arrays and assumed shape arrays must be dummy
+ arguments. */
+
+ 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;
+ }
+
+ /* Make sure symbols with known intent or optional are really dummy
+ variable. Because of ENTRY statement, this has to be deferred
+ until resolution time. */
+
+ 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 a derived type symbol has reached this point, without its
+ type being declared, we have an error. Notice that most
+ conditions that produce undefined derived types have already
+ been dealt with. However, the likes of:
+ implicit type(t) (t) ..... call foo (t) will get us here if
+ the type is not declared in the scope of the implicit
+ statement. Change the type to BT_UNKNOWN, both because it is so
+ and to prevent an ICE. */
+ 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;
+ }
+
+ /* An assumed-size array with INTENT(OUT) shall not be of a type for which
+ default initialization is defined (5.1.2.4.4). */
+ 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;
}
-
/* Make sure that intrinsic exist */
- if (sym->attr.intrinsic
+ if (sym->attr.flavor != FL_MODULE && 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);
gfc_resolve (sym->formal_ns);
formal_ns_flag = formal_ns_save;
}
+
+ /* Check threadprivate restrictions. */
+ 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 we have come this far we can apply default-initializers, as
+ described in 14.7.5, to those variables that have not already
+ been assigned one. */
+ 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);
+ }
}
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);
/* Warn about unused labels. */
static void
-warn_unused_label (gfc_namespace * ns)
+warn_unused_fortran_label (gfc_st_label * label)
{
- gfc_st_label *l;
-
- l = ns->st_labels;
- if (l == NULL)
+ if (label == NULL)
return;
- while (l->next)
- l = l->next;
+ warn_unused_fortran_label (label->left);
- for (; l; l = l->prev)
- {
- if (l->defined == ST_LABEL_UNKNOWN)
- continue;
+ if (label->defined == ST_LABEL_UNKNOWN)
+ return;
- switch (l->referenced)
- {
- case ST_LABEL_UNKNOWN:
- gfc_warning ("Label %d at %L defined but not used", l->value,
- &l->where);
- break;
+ 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", l->value,
- &l->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;
- }
+ default:
+ break;
}
+
+ warn_unused_fortran_label (label->right);
+}
+
+
+/* Returns the sequence type of a symbol or sequence. */
+
+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;
+ }
}
return FAILURE;
}
+ /* Shall not have allocatable components. */
+ 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;
-
+
/* Shall not be an object of sequence derived type containing a pointer
in the structure. */
if (c->pointer)
{
- gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
+ 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;
}
/* Resolve equivalence object.
- An EQUIVALENCE object shall not be a dummy argument, a pointer, an
- allocatable array, an object of nonsequence derived type, an object of
+ An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
+ an allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component
selection, an automatic object, a function name, an entry name, a result
name, a named constant, a structure component, or a subobject of any of
- the preceding objects. A substring shall not have length zero. */
+ the preceding objects. A substring shall not have length zero. A
+ derived type shall not have components with default initialization nor
+ shall two objects of an equivalence group be initialized.
+ The simple constraints are done in symbol.c(check_conflict) and the rest
+ are implemented here. */
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;
- for (; eq; eq = eq->eq)
+ first_sym = eq->expr->symtree->n.sym;
+
+ for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
continue;
sym = e->symtree->n.sym;
-
- /* Shall not be a dummy argument. */
- if (sym->attr.dummy)
- {
- gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
- /* Shall not be an allocatable array. */
- if (sym->attr.allocatable)
- {
- gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
+ /* An equivalence statement cannot have more than one initialized
+ object. */
+ 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;
+ }
- /* Shall not be a pointer. */
- if (sym->attr.pointer)
- {
- gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
- sym->name, &e->where);
- continue;
- }
-
- /* Shall not be a function name, ... */
- if (sym->attr.function || sym->attr.result || sym->attr.entry
- || sym->attr.subroutine)
+ /* Shall not equivalence common block variables in a PURE procedure. */
+ if (sym->ns->proc_name
+ && sym->ns->proc_name->attr.pure
+ && sym->attr.in_common)
{
- gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
- sym->name, &e->where);
- continue;
+ 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;
}
- /* Shall not be a named constant. */
+ /* Shall not be a named constant. */
if (e->expr_type == EXPR_CONSTANT)
{
gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
continue;
+ /* Check that the types correspond correctly:
+ Note 5.28:
+ A numeric sequence structure may be equivalenced to another sequence
+ structure, an object of default integer type, default real type, double
+ precision real type, default logical type such that components of the
+ structure ultimately only become associated to objects of the same
+ kind. A character sequence structure may be equivalenced to an object
+ of default character kind or another character sequence structure.
+ Other objects may be equivalenced only to objects of the same type and
+ kind parameters. */
+
+ /* Identical types are unconditionally OK. */
+ 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);
+
+ /* Since the pair of objects is not of the same type, mixed or
+ non-default sequences can be rejected. */
+
+ 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;
}
r = r->next;
}
- }
-}
+ }
+}
/* Resolve function and ENTRY types, issue diagnostics if needed. */
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);
+ }
+
+ /* Make sure that the type of a module derived type function is in the
+ module namespace, by copying it from the namespace's derived type
+ list, if necessary. */
+ 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)
{
}
}
+/* 12.3.2.1.1 Defined operators. */
-/* This function is called after a complete program unit has been compiled.
- Its purpose is to examine all of the expressions associated with a program
- unit, assign types to all intermediate expressions, make sure that all
- assignments are to compatible types and figure out which names refer to
- which functions or subroutines. */
+static void
+gfc_resolve_uops(gfc_symtree *symtree)
+{
+ gfc_interface *itr;
+ gfc_symbol *sym;
+ gfc_formal_arglist *formal;
-void
-gfc_resolve (gfc_namespace * ns)
+ 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);
+ }
+}
+
+
+/* Examine all of the expressions associated with a program unit,
+ assign types to all intermediate expressions, make sure that all
+ assignments are to compatible types and figure out which names
+ refer to which functions or subroutines. It doesn't check code
+ block, which is handled by resolve_code. */
+
+static void
+resolve_types (gfc_namespace * ns)
{
- gfc_namespace *old_ns, *n;
+ gfc_namespace *n;
gfc_charlen *cl;
gfc_data *d;
gfc_equiv *eq;
- old_ns = gfc_current_ns;
gfc_current_ns = ns;
resolve_entries (ns);
"also be PURE", n->proc_name->name,
&n->proc_name->declared_at);
- gfc_resolve (n);
+ resolve_types (n);
}
forall_flag = 0;
gfc_check_interfaces (ns);
for (cl = ns->cl_list; cl; cl = cl->next)
- {
- if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
- continue;
-
- if (gfc_simplify_expr (cl->length, 0) == FAILURE)
- continue;
-
- if (gfc_specification_expr (cl->length) == FAILURE)
- continue;
- }
+ resolve_charlen (cl);
gfc_traverse_ns (ns, resolve_values);
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
+ /* Warn about unused labels. */
+ if (warn_unused_label)
+ warn_unused_fortran_label (ns->st_labels);
+
+ gfc_resolve_uops (ns->uop_root);
+}
+
+
+/* Call resolve_code recursively. */
+
+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;
+ /* Set to an out of range value. */
+ current_entry_id = -1;
resolve_code (ns->code, ns);
+}
- /* Warn about unused labels. */
- if (gfc_option.warn_unused_labels)
- warn_unused_label (ns);
+
+/* This function is called after a complete program unit has been compiled.
+ Its purpose is to examine all of the expressions associated with a program
+ unit, assign types to all intermediate expressions, make sure that all
+ assignments are to compatible types and figure out which names refer to
+ which functions or subroutines. */
+
+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;
}
OSDN Git Service
