/* 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.
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;
gfc_namespace *child;
gfc_entry_list *el;
+ resolve_entries (ns);
+
resolve_formal_arglists (ns);
for (child = ns->contained; child; child = child->sibling)
}
/* Check references to assumed size arrays. The flag need_full_assumed_size
- is zero when matching actual arguments. */
+ is non-zero when matching actual arguments. */
-static int need_full_assumed_size = 1;
+static int need_full_assumed_size = 0;
-static int
+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
+ if (need_full_assumed_size
|| !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
- return 0;
+ return false;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY)
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 1;
+ return true;
}
- return 0;
+ return false;
}
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)
{
|| sym->attr.external)
{
- 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 (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 (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 the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
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_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 = 0;
+ need_full_assumed_size++;
if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
return FAILURE;
/* Resume assumed_size checking. */
- need_full_assumed_size = 1;
+ need_full_assumed_size--;
+
+ if (sym && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl && sym->ts.cl->length == NULL)
+ {
+ if (sym->attr.if_source == IFSRC_IFBODY)
+ {
+ /* This follows from a slightly odd requirement at 5.1.1.5 in the
+ standard that allows assumed character length functions to be
+ declared in interfaces but not used. Picking up the symbol here,
+ rather than resolve_symbol, accomplishes that. */
+ gfc_error ("Function '%s' can be declared in an interface to "
+ "return CHARACTER(*) but cannot be used at %L",
+ sym->name, &expr->where);
+ return FAILURE;
+ }
+
+ /* Internal procedures are taken care of in resolve_contained_fntype. */
+ if (!sym->attr.dummy && !sym->attr.contained)
+ {
+ gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
+ "be used at %L since it is not a dummy argument",
+ sym->name, &expr->where);
+ return FAILURE;
+ }
+ }
/* 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;
+ temp = need_full_assumed_size;
+ need_full_assumed_size = 0;
+
if (expr->value.function.actual != NULL
&& ((expr->value.function.esym != NULL
&& expr->value.function.esym->attr.elemental)
&& expr->value.function.isym->elemental)))
{
/* The rank of an elemental is the rank of its array argument(s). */
-
for (arg = expr->value.function.actual; arg; arg = arg->next)
{
if (arg->expr != NULL && arg->expr->rank > 0)
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;
+ }
else if (expr->value.function.actual != NULL
- && expr->value.function.isym != NULL
- && strcmp (expr->value.function.isym->name, "lbound"))
+ && 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 instrinsics must also have the last upper bound of an
- asumed size array argument. */
+ asumed 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 (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))
}
}
+ need_full_assumed_size = temp;
+
if (!pure_function (expr, &name))
{
if (forall_flag)
}
}
+ /* 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);
{
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);
+
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
- need_full_assumed_size = 0;
+ need_full_assumed_size++;
if (resolve_actual_arglist (c->ext.actual) == FAILURE)
return FAILURE;
/* Resume assumed_size checking. */
- need_full_assumed_size = 1;
+ need_full_assumed_size--;
t = SUCCESS;
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
return FAILURE;
break;
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)
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;
}
-/* 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);
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;
}
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;
case EXEC_IOLENGTH:
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ break;
+
default:
gfc_internal_error ("resolve_block(): Bad block type");
}
static void
resolve_code (gfc_code * code, gfc_namespace * ns)
{
- int forall_save = 0;
+ int omp_workshare_save;
code_stack frame;
gfc_alloc *a;
try t;
if (code->op == EXEC_FORALL)
{
- forall_save = forall_flag;
+ int 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 = forall_save;
+ }
+ 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);
if (gfc_resolve_expr (code->expr2) == FAILURE)
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))
{
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:
&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");
}
}
-/* Resolve a charlen structure. */
+/* Resolve an index expression. */
static try
-resolve_charlen (gfc_charlen *cl)
+resolve_index_expr (gfc_expr * e)
{
- if (cl->resolved)
- return SUCCESS;
-
- cl->resolved = 1;
- if (gfc_resolve_expr (cl->length) == FAILURE)
+ if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
- if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+ if (gfc_simplify_expr (e, 0) == FAILURE)
return FAILURE;
- if (gfc_specification_expr (cl->length) == FAILURE)
+ if (gfc_specification_expr (e) == FAILURE)
return FAILURE;
return SUCCESS;
}
-
-/* Resolve the components of a derived type. */
+/* Resolve a charlen structure. */
static try
-resolve_derived (gfc_symbol *sym)
+resolve_charlen (gfc_charlen *cl)
{
- gfc_component *c;
+ if (cl->resolved)
+ return SUCCESS;
- for (c = sym->components; c != NULL; c = c->next)
- {
- if (c->ts.type == BT_CHARACTER)
- {
- if (resolve_charlen (c->ts.cl) == FAILURE)
- return FAILURE;
-
- if (c->ts.cl->length == NULL
- || !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;
- }
- }
+ cl->resolved = 1;
- /* TODO: Anything else that should be done here? */
- }
+ if (resolve_index_expr (cl->length) == FAILURE)
+ 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)
+/* Test for non-constant shape arrays. */
+
+static bool
+is_non_constant_shape_array (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;
- int i, flag;
- gfc_namelist *nl;
- gfc_symtree * symtree;
- gfc_symtree * this_symtree;
- gfc_namespace * ns;
- gfc_component * c;
- gfc_formal_arglist * arg;
+ gfc_expr *e;
+ int i;
- if (sym->attr.flavor == FL_UNKNOWN)
+ if (sym->as != NULL)
{
-
- /* 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
+ /* 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)))
+ return true;
+
+ e = sym->as->upper[i];
+ if (e && (resolve_index_expr (e) == FAILURE
+ || !gfc_is_constant_expr (e)))
+ return true;
}
}
+ return false;
+}
- if (sym->attr.flavor == FL_DERIVED && resolve_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);
+/* Resolution of common features of flavors variable and procedure. */
- /* Assign default type to symbols that need one and don't have one. */
- if (sym->ts.type == BT_UNKNOWN)
+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.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
- gfc_set_default_type (sym, 1, NULL);
-
- if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
+ if (sym->attr.allocatable)
{
- /* 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);
+ if (sym->attr.dimension)
+ gfc_error ("Allocatable array '%s' at %L must have "
+ "a deferred shape", sym->name, &sym->declared_at);
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;
- }
+ gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
+ sym->name, &sym->declared_at);
+ return FAILURE;
}
- }
- /* Assumed size arrays and assumed shape arrays must be dummy
- arguments. */
+ 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;
+ }
- if (sym->as != NULL
- && (sym->as->type == AS_ASSUMED_SIZE
- || sym->as->type == AS_ASSUMED_SHAPE)
- && sym->attr.dummy == 0)
+ }
+ else
{
- if (sym->as->type == AS_ASSUMED_SIZE)
- gfc_error ("Assumed size array at %L must be a dummy argument",
- &sym->declared_at);
- else
- gfc_error ("Assumed shape array at %L must be a dummy argument",
- &sym->declared_at);
- return;
+ if (!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;
+}
- /* A parameter array's shape needs to be constant. */
+/* Resolve symbols with flavor variable. */
- if (sym->attr.flavor == FL_PARAMETER && 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;
- }
+static try
+resolve_fl_variable (gfc_symbol *sym, int mp_flag)
+{
+ int flag;
+ int i;
+ gfc_expr *e;
+ gfc_expr *constructor_expr;
- /* A module array's shape needs to be constant. */
+ if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
+ return FAILURE;
+ /* The shape of a main program or module array needs to be constant. */
if (sym->ns->proc_name
- && sym->attr.flavor == FL_VARIABLE
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && !sym->attr.use_assoc
- && !sym->attr.allocatable
- && !sym->attr.pointer
- && sym->as != NULL
- && !gfc_is_compile_time_shape (sym->as))
- {
- gfc_error ("Module array '%s' at %L cannot be automatic "
- "or assumed shape", sym->name, &sym->declared_at);
- return;
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && is_non_constant_shape_array (sym))
+ {
+ gfc_error ("The module or main program array '%s' at %L must "
+ "have constant shape", sym->name, &sym->declared_at);
+ return FAILURE;
}
- /* Make sure that character string variables with assumed length are
- dummy arguments. */
-
- if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
- && sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
+ if (sym->ts.type == BT_CHARACTER)
{
- gfc_error ("Entity with assumed character length at %L must be a "
- "dummy argument or a PARAMETER", &sym->declared_at);
- return;
+ /* 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)
+ {
+ gfc_error ("Entity with assumed character length at %L must be a "
+ "dummy argument or a PARAMETER", &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (!gfc_is_constant_expr (e)
+ && !(e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc)
+ {
+ gfc_error ("'%s' at %L must have constant character length "
+ "in this context", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
}
- /* Make sure a parameter that has been implicitly typed still
- matches the implicit type, since PARAMETER statements can precede
- IMPLICIT statements. */
-
- 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);
+ /* 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)
+ {
+ /* 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)
+ {
+ flag = 1;
+ break;
+ }
+ }
+ }
- /* 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. */
+ /* 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;
+ }
- 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);
+ /* 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." */
- /* Make sure symbols with known intent or optional are really dummy
- variable. Because of ENTRY statement, this has to be deferred
- until resolution time. */
+ constructor_expr = NULL;
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
+ constructor_expr = gfc_default_initializer (&sym->ts);
- if (! sym->attr.dummy
- && (sym->attr.optional
- || sym->attr.intent != INTENT_UNKNOWN))
- {
- gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
- return;
+ if (sym->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 || flag)
+ && !sym->attr.pointer)
+ 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->attr.proc == PROC_ST_FUNCTION)
{
if (sym->ts.type == BT_CHARACTER)
{
gfc_error ("Character-valued statement function '%s' at %L must "
"have constant length", sym->name, &sym->declared_at);
- return;
+ return FAILURE;
}
}
}
- /* 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)
+ /* Ensure that derived type formal arguments of a public procedure
+ are not of a private type. */
+ if (gfc_check_access(sym->attr.access, sym->ns->default_access))
{
- 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;
+ 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;
+ }
+ }
}
- /* If a component of a derived type is of a type declared to be private,
- either the derived type definition must contain the PRIVATE statement,
- or the derived type must be private. (4.4.1 just after R427) */
- if (sym->attr.flavor == FL_DERIVED
- && sym->component_access != ACCESS_PRIVATE
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ /* An external symbol may not have an intializer because it is taken to be
+ a procedure. */
+ if (sym->attr.external && sym->value)
{
- for (c = sym->components; c; c = c->next)
+ gfc_error ("External object '%s' at %L may not have an initializer",
+ sym->name, &sym->declared_at);
+ 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 (c->ts.type == BT_DERIVED
- && !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;
- }
+ 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;
+}
- /* 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)
+
+/* 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)
{
- for (c = sym->ts.derived->components; c; c = c->next)
+ if (c->ts.type == BT_CHARACTER)
{
- if (c->initializer)
+ 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 (c->pointer || 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 ("The INTENT(OUT) dummy argument '%s' at %L is "
- "ASSUMED SIZE and so cannot have a default initializer",
- sym->name, &sym->declared_at);
- return;
+ 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. */
+ 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;
+}
- /* Ensure that derived type formal arguments of a public procedure
- are not of a private type. */
- if (sym->attr.flavor == FL_PROCEDURE
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+
+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 (arg = sym->formal; arg; arg = arg->next)
+ for (nl = sym->namelist; nl; nl = nl->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))
+ 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_now ("'%s' is 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;
+ gfc_error ("PRIVATE symbol '%s' cannot be member of "
+ "PUBLIC namelist at %L", nl->sym->name,
+ &sym->declared_at);
+ return FAILURE;
}
}
}
- /* Constraints on deferred shape variable. */
- if (sym->attr.flavor == FL_VARIABLE
- || (sym->attr.flavor == FL_PROCEDURE
- && sym->attr.function))
+ /* 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;
+ }
+ }
+
+ /* 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 (sym->as == NULL || sym->as->type != AS_DEFERRED)
+ 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)
{
- if (sym->attr.allocatable)
+ symtree = gfc_find_symtree (ns->sym_root, sym->name);
+ if (symtree && symtree->n.sym->generic)
{
- 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);
+ this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ sym->name);
+ sym->refs--;
+ if (!sym->refs)
+ gfc_free_symbol (sym);
+ symtree->n.sym->refs++;
+ this_symtree->n.sym = symtree->n.sym;
return;
}
+ }
- if (sym->attr.pointer && sym->attr.dimension)
+ /* 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
{
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
- return;
- }
+ /* 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;
+ }
}
+ }
+
+ /* 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 (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
+ if (c->initializer)
{
- gfc_error ("Array '%s' at %L cannot have a deferred shape",
+ 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:
- /* 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)
- {
- /* 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)
- {
- flag = 1;
- break;
- }
- }
- }
-
- /* 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;
- }
+ if (resolve_fl_variable (sym, mp_flag) == FAILURE)
+ return;
+ break;
- /* Assign default initializer. */
- if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
- && !sym->attr.pointer)
- sym->value = gfc_default_initializer (&sym->ts);
+ case FL_PROCEDURE:
+ if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
+ return;
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 (!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);
- }
- }
+ if (resolve_fl_namelist (sym) == FAILURE)
+ return;
break;
- case FL_DERIVED:
- /* Add derived type to the derived type list. */
- {
- gfc_dt_list * dt_list;
- dt_list = gfc_get_dt_list ();
- dt_list->next = sym->ns->derived_types;
- dt_list->derived = sym;
- sym->ns->derived_types = dt_list;
- }
+ case FL_PARAMETER:
+ if (resolve_fl_parameter (sym) == FAILURE)
+ return;
+
break;
default:
- /* An external symbol falls through to here if it is not referenced. */
- if (sym->attr.external && sym->value)
- {
- gfc_error ("External object '%s' at %L may not have an initializer",
- sym->name, &sym->declared_at);
- return;
- }
-
break;
}
-
/* Make sure that intrinsic exist */
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
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 (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_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_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_label (label->right);
}
sym->attr.untyped = 1;
}
+ if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (sym->ts.derived->attr.access,
+ sym->ts.derived->ns->default_access)
+ && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ {
+ gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
+ sym->name, &sym->declared_at, sym->ts.derived->name);
+ }
+
if (ns->entries)
for (el = ns->entries->next; el; el = el->next)
{
}
-/* 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. */
+/* 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. */
-void
-gfc_resolve (gfc_namespace * ns)
+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);
-
- resolve_contained_functions (ns);
-
gfc_traverse_ns (ns, resolve_symbol);
resolve_fntype (ns);
"also be PURE", n->proc_name->name,
&n->proc_name->declared_at);
- gfc_resolve (n);
+ resolve_types (n);
}
forall_flag = 0;
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
+ /* Warn about unused labels. */
+ if (gfc_option.warn_unused_labels)
+ warn_unused_label (ns->st_labels);
+}
+
+
+/* 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;
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_contained_functions (ns);
+ resolve_types (ns);
+ resolve_codes (ns);
gfc_current_ns = old_ns;
}
OSDN Git Service
