-/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+/* Perform type resolution on the various structures.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "arith.h" /* For gfc_compare_expr(). */
#include "dependency.h"
#include "data.h"
+#include "target-memory.h" /* for gfc_simplify_transfer */
/* Types used in equivalence statements. */
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
|| (sym->as && sym->as->rank > 0))
- proc->attr.always_explicit = 1;
+ {
+ proc->attr.always_explicit = 1;
+ sym->attr.always_explicit = 1;
+ }
formal_arg_flag = 1;
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| sym->attr.optional)
- proc->attr.always_explicit = 1;
+ {
+ proc->attr.always_explicit = 1;
+ if (proc->result)
+ proc->result->attr.always_explicit = 1;
+ }
/* If the flavor is unknown at this point, it has to be a variable.
A procedure specification would have already set the type. */
&sym->declared_at);
continue;
}
+
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_error ("Dummy procedure '%s' not allowed in elemental "
+ "procedure '%s' at %L", sym->name, proc->name,
+ &sym->declared_at);
+ continue;
+ }
}
/* Each dummy shall be specified to be scalar. */
static void
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
- try t;
+ gfc_try t;
/* If this namespace is not a function or an entry master function,
ignore it. */
|| (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 "
+ else if (as && fas && ns->entries->sym->result != el->sym->result
+ && gfc_compare_array_spec (as, fas) == 0)
+ gfc_error ("Function %s at %L has entries with mismatched "
"array specifications", ns->entries->sym->name,
&ns->entries->sym->declared_at);
+ /* The characteristics need to match and thus both need to have
+ the same string length, i.e. both len=*, or both len=4.
+ Having both len=<variable> is also possible, but difficult to
+ check at compile time. */
+ else if (ts->type == BT_CHARACTER && ts->cl && fts->cl
+ && (((ts->cl->length && !fts->cl->length)
+ ||(!ts->cl->length && fts->cl->length))
+ || (ts->cl->length
+ && ts->cl->length->expr_type
+ != fts->cl->length->expr_type)
+ || (ts->cl->length
+ && ts->cl->length->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ts->cl->length->value.integer,
+ fts->cl->length->value.integer) != 0)))
+ gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
+ "entries returning variables of different "
+ "string lengths", ns->entries->sym->name,
+ &ns->entries->sym->declared_at);
}
if (el == NULL)
for (c = der->components; c; c = c->next)
if ((c->ts.type != BT_DERIVED && c->initializer)
|| (c->ts.type == BT_DERIVED
- && (!c->pointer && has_default_initializer (c->ts.derived))))
+ && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
break;
return c != NULL;
}
-
-/* Resolve common blocks. */
+/* Resolve common variables. */
static void
-resolve_common_blocks (gfc_symtree *common_root)
+resolve_common_vars (gfc_symbol *sym, bool named_common)
{
- gfc_symbol *sym, *csym;
+ gfc_symbol *csym = sym;
- if (common_root == NULL)
- return;
-
- if (common_root->left)
- resolve_common_blocks (common_root->left);
- if (common_root->right)
- resolve_common_blocks (common_root->right);
-
- for (csym = common_root->n.common->head; csym; csym = csym->common_next)
+ for (; csym; csym = csym->common_next)
{
+ if (csym->value || csym->attr.data)
+ {
+ if (!csym->ns->is_block_data)
+ gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
+ "but only in BLOCK DATA initialization is "
+ "allowed", csym->name, &csym->declared_at);
+ else if (!named_common)
+ gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
+ "in a blank COMMON but initialization is only "
+ "allowed in named common blocks", csym->name,
+ &csym->declared_at);
+ }
+
if (csym->ts.type != BT_DERIVED)
continue;
"may not have default initializer", csym->name,
&csym->declared_at);
}
+}
+
+/* Resolve common blocks. */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+ gfc_symbol *sym;
+
+ if (common_root == NULL)
+ return;
+
+ if (common_root->left)
+ resolve_common_blocks (common_root->left);
+ if (common_root->right)
+ resolve_common_blocks (common_root->right);
+
+ resolve_common_vars (common_root->n.common->head, true);
gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
if (sym == NULL)
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. */
-static try
+static gfc_try
resolve_structure_cons (gfc_expr *expr)
{
gfc_constructor *cons;
gfc_component *comp;
- try t;
+ gfc_try t;
symbol_attribute a;
t = SUCCESS;
rank = comp->as ? comp->as->rank : 0;
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
- && (comp->allocatable || cons->expr->rank))
+ && (comp->attr.allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (comp->attr.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,
t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
- if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
+ if (cons->expr->expr_type == EXPR_NULL
+ && !(comp->attr.pointer || comp->attr.allocatable))
+ {
+ t = FAILURE;
+ gfc_error ("The NULL in the derived type constructor at %L is "
+ "being applied to component '%s', which is neither "
+ "a POINTER nor ALLOCATABLE", &cons->expr->where,
+ comp->name);
+ }
+
+ if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
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)
+ if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
+ && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+ && (e->ref->u.ar.type == DIMEN_ELEMENT))
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
that look like procedure arguments are really simple variable
references. */
-static try
+static gfc_try
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
+ int save_need_full_assumed_size;
for (; arg; arg = arg->next)
{
if (e->ts.type != BT_PROCEDURE)
{
+ save_need_full_assumed_size = need_full_assumed_size;
+ if (e->expr_type != FL_VARIABLE)
+ need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
+ need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
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))
+ && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
primary.c (match_actual_arg). If above code determines that it
is a variable instead, it needs to be resolved as it was not
done at the beginning of this function. */
+ save_need_full_assumed_size = need_full_assumed_size;
+ if (e->expr_type != FL_VARIABLE)
+ need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
+ need_full_assumed_size = save_need_full_assumed_size;
argument_list:
/* Check argument list functions %VAL, %LOC and %REF. There is
procedures. If called with c == NULL, we have a function, otherwise if
expr == NULL, we have a subroutine. */
-static try
+static gfc_try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
gfc_actual_arglist *arg0;
else if (s->result != NULL && s->result->as != NULL)
expr->rank = s->result->as->rank;
+ gfc_set_sym_referenced (expr->value.function.esym);
+
return MATCH_YES;
}
}
-static try
+static gfc_try
resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
- if (sym && !gfc_intrinsic_name (sym->name, 0))
+ if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
{
gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
/* See if we have an intrinsic interface. */
- if (sym->interface != NULL && sym->interface->attr.intrinsic)
+ if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->interface->name);
+ isym = gfc_find_function (sym->ts.interface->name);
- /* Existance of isym should be checked already. */
+ /* Existence of isym should be checked already. */
gcc_assert (isym);
- sym->ts = isym->ts;
+ sym->ts.type = isym->ts.type;
+ sym->ts.kind = isym->ts.kind;
sym->attr.function = 1;
sym->attr.proc = PROC_EXTERNAL;
goto found;
}
-static try
+static gfc_try
resolve_specific_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* Resolve a procedure call not known to be generic nor specific. */
-static try
+static gfc_try
resolve_unknown_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* See if we have an intrinsic function reference. */
- if (gfc_intrinsic_name (sym->name, 0))
+ if (gfc_is_intrinsic (sym, 0, expr->where))
{
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
return SUCCESS;
{
if (!sym->attr.dummy && !sym->attr.contained
&& !(sym->attr.intrinsic
- || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.use_assoc
&& sym->name)
return true;
- else
- return false;
+
+ return false;
}
/* Figure out if a function reference is pure or not. Also set the name
of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
+static int
+pure_stmt_function (gfc_expr *, gfc_symbol *);
static int
pure_function (gfc_expr *e, const char **name)
if (e->symtree != NULL
&& e->symtree->n.sym != NULL
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
- return 1;
+ return pure_stmt_function (e, e->symtree->n.sym);
if (e->value.function.esym)
{
}
-static try
+static bool
+impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
+ int *f ATTRIBUTE_UNUSED)
+{
+ const char *name;
+
+ /* Don't bother recursing into other statement functions
+ since they will be checked individually for purity. */
+ if (e->expr_type != EXPR_FUNCTION
+ || !e->symtree
+ || e->symtree->n.sym == sym
+ || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+ return false;
+
+ return pure_function (e, &name) ? false : true;
+}
+
+
+static int
+pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
+{
+ return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
+}
+
+
+static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
gfc_ref *ref;
int start;
int end;
and, in the case of c_associated, set the binding label based on
the arguments. */
-static try
+static gfc_try
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
int optional_arg = 0;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
gfc_typespec *arg_ts;
gfc_ref *parent_ref;
if (!(args_sym->attr.target)
&& !(args_sym->attr.pointer)
&& (parent_ref == NULL ||
- !parent_ref->u.c.component->pointer))
+ !parent_ref->u.c.component->attr.pointer))
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
}
else if ((args_sym->attr.pointer == 1 ||
(parent_ref != NULL
- && parent_ref->u.c.component->pointer))
+ && parent_ref->u.c.component->attr.pointer))
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
to INTENT(OUT) or INTENT(INOUT). */
-static try
+static gfc_try
resolve_function (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_symbol *sym;
const char *name;
- try t;
+ gfc_try t;
int temp;
procedure_type p = PROC_INTRINSIC;
gfc_expr_set_symbols_referenced (expr->ts.cl->length);
}
- if (t == SUCCESS)
+ if (t == SUCCESS
+ && !((expr->value.function.esym
+ && expr->value.function.esym->attr.elemental)
+ ||
+ (expr->value.function.isym
+ && expr->value.function.isym->elemental)))
find_noncopying_intrinsics (expr->value.function.esym,
expr->value.function.actual);
}
-static try
+static gfc_try
resolve_generic_s (gfc_code *c)
{
gfc_symbol *sym;
that possesses a matching interface. 14.1.2.4 */
sym = c->symtree->n.sym;
- if (!gfc_intrinsic_name (sym->name, 1))
+ if (!gfc_is_intrinsic (sym, 1, c->loc))
{
gfc_error ("There is no specific subroutine for the generic '%s' at %L",
sym->name, &c->loc);
match m;
/* See if we have an intrinsic interface. */
- if (sym->interface != NULL && !sym->interface->attr.abstract
- && !sym->interface->attr.subroutine)
+ if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
+ && !sym->ts.interface->attr.subroutine)
{
gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->interface->name);
+ isym = gfc_find_function (sym->ts.interface->name);
- /* Existance of isym should be checked already. */
+ /* Existence of isym should be checked already. */
gcc_assert (isym);
- sym->ts = isym->ts;
- sym->attr.function = 1;
+ sym->ts.type = isym->ts.type;
+ sym->ts.kind = isym->ts.kind;
+ sym->attr.subroutine = 1;
goto found;
}
}
-static try
+static gfc_try
resolve_specific_s (gfc_code *c)
{
gfc_symbol *sym;
/* Resolve a subroutine call not known to be generic nor specific. */
-static try
+static gfc_try
resolve_unknown_s (gfc_code *c)
{
gfc_symbol *sym;
/* See if we have an intrinsic function reference. */
- if (gfc_intrinsic_name (sym->name, 1))
+ if (gfc_is_intrinsic (sym, 1, c->loc))
{
if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
return SUCCESS;
for functions, subroutines and functions are stored differently and this
makes things awkward. */
-static try
+static gfc_try
resolve_call (gfc_code *c)
{
- try t;
+ gfc_try t;
procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
- if (t == SUCCESS)
+ if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
if their shapes do not match. If either op1->shape or op2->shape is
NULL, return SUCCESS. */
-static try
+static gfc_try
compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
- try t;
+ gfc_try t;
int i;
t = SUCCESS;
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
-static try
+static gfc_try
resolve_operator (gfc_expr *e)
{
gfc_expr *op1, *op2;
char msg[200];
bool dual_locus_error;
- try t;
+ gfc_try t;
/* Resolve all subnodes-- give them types. */
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
default:
if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
goto bad_op;
}
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
}
sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
goto bad_op;
case INTRINSIC_PLUS:
sprintf (msg,
_("Operands of binary numeric operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_CONCAT:
- if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->ts.kind == op2->ts.kind)
{
e->ts.type = BT_CHARACTER;
e->ts.kind = op1->ts.kind;
}
sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->ts.kind == op2->ts.kind)
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_default_logical_kind;
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
_("Logicals at %%L must be compared with %s instead of %s"),
- (e->value.op.operator == INTRINSIC_EQ
- || e->value.op.operator == INTRINSIC_EQ_OS)
- ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
+ (e->value.op.op == INTRINSIC_EQ
+ || e->value.op.op == INTRINSIC_EQ_OS)
+ ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
else
sprintf (msg,
_("Operands of comparison operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
- if (e->value.op.uop->operator == NULL)
+ if (e->value.op.uop->op == NULL)
sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
t = SUCCESS;
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
{
t = gfc_simplify_expr (e, 0);
/* Some calls do not succeed in simplification and return FAILURE
- even though there is no error; eg. variable references to
+ even though there is no error; e.g. variable references to
PARAMETER arrays. */
if (!gfc_is_constant_expr (e))
t = SUCCESS;
|| b == NULL || b->expr_type != EXPR_CONSTANT)
return CMP_UNKNOWN;
+ /* If either of the types isn't INTEGER, we must have
+ raised an error earlier. */
+
if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
- gfc_internal_error ("compare_bound(): Bad expression");
+ return CMP_UNKNOWN;
i = mpz_cmp (a->value.integer, b->value.integer);
/* Compare a single dimension of an array reference to the array
specification. */
-static try
+static gfc_try
check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
{
mpz_t last_value;
/* Compare an array reference with an array specification. */
-static try
+static gfc_try
compare_spec_to_ref (gfc_array_ref *ar)
{
gfc_array_spec *as;
/* Resolve one part of an array index. */
-try
+gfc_try
gfc_resolve_index (gfc_expr *index, int check_scalar)
{
gfc_typespec ts;
if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
{
- gfc_error ("Array index at %L must be of INTEGER type",
- &index->where);
+ gfc_error ("Array index at %L must be of INTEGER type, found %s",
+ &index->where, gfc_basic_typename (index->ts.type));
return FAILURE;
}
/* Resolve a dim argument to an intrinsic function. */
-try
+gfc_try
gfc_resolve_dim_arg (gfc_expr *dim)
{
if (dim == NULL)
if (c == NULL)
gfc_internal_error ("find_array_spec(): Component not found");
- if (c->dimension)
+ if (c->attr.dimension)
{
if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
/* Resolve an array reference. */
-static try
+static gfc_try
resolve_array_ref (gfc_array_ref *ar)
{
int i, check_scalar;
}
-static try
+static gfc_try
resolve_substring (gfc_ref *ref)
{
if (ref->u.ss.start != NULL)
/* Resolve subtype references. */
-static try
+static gfc_try
resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
- if (ref->u.c.component->pointer)
+ if (ref->u.c.component->attr.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)
+ else if (ref->u.c.component->attr.allocatable)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
/* Resolve a variable expression. */
-static try
+static gfc_try
resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
- try t;
+ gfc_try t;
t = SUCCESS;
gfc_expr *e1 = NULL;
gfc_expr *e2 = NULL;
- gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
+ gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
if (op1->ts.cl && op1->ts.cl->length)
e1 = gfc_copy_expr (op1->ts.cl->length);
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
-try
+gfc_try
gfc_resolve_expr (gfc_expr *e)
{
- try t;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
/* This provides the opportunity for the length of constructors with
character valued function elements to propagate the string length
to the expression. */
- if (e->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (e);
+ if (t == SUCCESS && e->ts.type == BT_CHARACTER)
+ t = gfc_resolve_character_array_constructor (e);
break;
/* Resolve an expression from an iterator. They must be scalar and have
INTEGER or (optionally) REAL type. */
-static try
+static gfc_try
gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
const char *name_msgid)
{
/* Resolve the expressions in an iterator structure. If REAL_OK is
false allow only INTEGER type iterators, otherwise allow REAL types. */
-try
+gfc_try
gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
{
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
static bool
forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
{
- gcc_assert (expr->expr_type == EXPR_VARIABLE);
-
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
/* A scalar assignment */
if (!expr->ref || *f == 1)
{
/* Check whether the FORALL index appears in the expression or not.
Returns SUCCESS if SYM is found in EXPR. */
-try
+gfc_try
find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
{
if (gfc_traverse_expr (expr, sym, forall_index, f))
/* Resolve the argument of a deallocate expression. The expression must be
a pointer or a full array. */
-static try
+static gfc_try
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
+ pointer = ref->u.c.component->attr.pointer;
break;
case REF_SUBSTRING:
}
-/* Returns true if the expression e contains a reference the symbol sym. */
+/* Returns true if the expression e contains a reference to the symbol sym. */
static bool
-find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
- 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;
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
+ return true;
- 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);
+ return false;
+}
- 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;
+bool
+gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+{
+ return gfc_traverse_expr (e, sym, sym_in_expr, 0);
}
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
+static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in;
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
- dimension = ref->u.c.component->dimension;
+ pointer = ref->u.c.component->attr.pointer;
+ dimension = ref->u.c.component->attr.dimension;
break;
case REF_SUBSTRING:
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])))
+ if ((ar->start[i] != NULL
+ && gfc_find_sym_in_expr (sym, ar->start[i]))
+ || (ar->end[i] != NULL
+ && gfc_find_sym_in_expr (sym, ar->end[i])))
{
- gfc_error ("'%s' must not appear an the array specification at "
+ gfc_error ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
return FAILURE;
return SUCCESS;
}
+static void
+resolve_allocate_deallocate (gfc_code *code, const char *fcn)
+{
+ gfc_symbol *s = NULL;
+ gfc_alloc *a;
+
+ if (code->expr)
+ s = code->expr->symtree->n.sym;
+
+ if (s)
+ {
+ if (s->attr.intent == INTENT_IN)
+ gfc_error ("STAT variable '%s' of %s statement at %C cannot "
+ "be INTENT(IN)", s->name, fcn);
+
+ if (gfc_pure (NULL) && gfc_impure_variable (s))
+ gfc_error ("Illegal STAT variable in %s statement at %C "
+ "for a PURE procedure", fcn);
+ }
+
+ if (s && code->expr->ts.type != BT_INTEGER)
+ gfc_error ("STAT tag in %s statement at %L must be "
+ "of type INTEGER", fcn, &code->expr->where);
+
+ if (strcmp (fcn, "ALLOCATE") == 0)
+ {
+ for (a = code->ext.alloc_list; a; a = a->next)
+ resolve_allocate_expr (a->expr, code);
+ }
+ else
+ {
+ for (a = code->ext.alloc_list; a; a = a->next)
+ resolve_deallocate_expr (a->expr);
+ }
+}
/************ SELECT CASE resolution subroutines ************/
retval = 0;
/* op2 = (M:) or (M:N), L < M */
if (op2->low != NULL
- && gfc_compare_expr (op1->high, op2->low) < 0)
+ && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1;
}
else if (op1->high == NULL) /* op1 = (K:) */
retval = 0;
/* op2 = (:N) or (M:N), K > N */
if (op2->high != NULL
- && gfc_compare_expr (op1->low, op2->high) > 0)
+ && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1;
}
else /* op1 = (K:L) */
{
if (op2->low == NULL) /* op2 = (:N), K > N */
- retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
+ retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
+ ? 1 : 0;
else if (op2->high == NULL) /* op2 = (M:), L < M */
- retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
+ retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
+ ? -1 : 0;
else /* op2 = (M:N) */
{
retval = 0;
/* L < M */
- if (gfc_compare_expr (op1->high, op2->low) < 0)
+ if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1;
/* K > N */
- else if (gfc_compare_expr (op1->low, op2->high) > 0)
+ else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1;
}
}
Makes sure that all case expressions are scalar constants of the same
type. Return FAILURE if anything is wrong. */
-static try
+static gfc_try
validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
{
if (e == NULL) return SUCCESS;
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
- gfc_error("Expression in CASE statement at %L must be kind %d",
- &e->where, case_expr->ts.kind);
+ gfc_error ("Expression in CASE statement at %L must be of kind %d",
+ &e->where, case_expr->ts.kind);
return FAILURE;
}
int seen_logical;
int ncases;
bt type;
- try t;
+ gfc_try t;
if (code->expr == NULL)
{
/* 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)
+ && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue;
/* FIXME: Should a warning be issued? */
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
- && gfc_compare_expr (cp->low, cp->high) > 0)
+ && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
{
if (gfc_option.warn_surprising)
gfc_warning ("Range specification at %L can never "
if (code->here == label)
{
- gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
+ gfc_warning ("Branch at %L may result in an infinite loop", &code->loc);
return;
}
/* Check whether EXPR1 has the same shape as EXPR2. */
-static try
+static gfc_try
resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
mpz_t shape2[GFC_MAX_DIMENSIONS];
- try result = FAILURE;
+ gfc_try result = FAILURE;
int i;
/* Compare the rank. */
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
+ if (!cnext->resolved_sym->attr.elemental)
+ gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
+ &cnext->ext.actual->expr->where);
break;
/* WHERE or WHERE construct is part of a where-body-construct */
/* WHERE operator assignment statement */
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
+ if (!cnext->resolved_sym->attr.elemental)
+ gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
+ &cnext->ext.actual->expr->where);
break;
/* WHERE or WHERE construct is part of a where-body-construct */
void
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
- try t;
+ gfc_try t;
for (; b; b = b->block)
{
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
+ case EXEC_WAIT:
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKWAIT:
case EXEC_OMP_WORKSHARE:
break;
/* Does everything to resolve an ordinary assignment. Returns true
- if this is an interface asignment. */
+ if this is an interface assignment. */
static bool
resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
{
int n;
gfc_ref *ref;
-
if (gfc_extend_assign (code, ns) == SUCCESS)
{
lhs = code->ext.actual->expr;
lhs = code->expr;
rhs = code->expr2;
+ if (rhs->is_boz
+ && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
+ "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+ &code->loc) == FAILURE)
+ return false;
+
+ /* Handle the case of a BOZ literal on the RHS. */
+ if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
+ {
+ int rc;
+ if (gfc_option.warn_surprising)
+ gfc_warning ("BOZ literal at %L is bitwise transferred "
+ "non-integer symbol '%s'", &code->loc,
+ lhs->symtree->n.sym->name);
+
+ if (!gfc_convert_boz (rhs, &lhs->ts))
+ return false;
+ if ((rc = gfc_range_check (rhs)) != ARITH_OK)
+ {
+ if (rc == ARITH_UNDERFLOW)
+ gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
+ ". This check can be disabled with the option "
+ "-fno-range-check", &rhs->where);
+ else if (rc == ARITH_OVERFLOW)
+ gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
+ ". This check can be disabled with the option "
+ "-fno-range-check", &rhs->where);
+ else if (rc == ARITH_NAN)
+ gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
+ ". This check can be disabled with the option "
+ "-fno-range-check", &rhs->where);
+ return false;
+ }
+ }
+
+
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
}
/* Ensure that a vector index expression for the lvalue is evaluated
- to a temporary. */
+ to a temporary if the lvalue symbol is referenced in it. */
if (lhs->rank)
{
for (ref = lhs->ref; ref; ref= ref->next)
if (ref->type == REF_ARRAY)
{
for (n = 0; n < ref->u.ar.dimen; n++)
- if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+ if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
+ && gfc_find_sym_in_expr (lhs->symtree->n.sym,
+ ref->u.ar.start[n]))
ref->u.ar.start[n]
= gfc_get_parentheses (ref->u.ar.start[n]);
}
int omp_workshare_save;
int forall_save;
code_stack frame;
- gfc_alloc *a;
- try t;
+ gfc_try t;
frame.prev = cs_base;
frame.head = code;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_parallel_blocks (code, ns);
break;
case EXEC_ALLOCATE:
- if (t == SUCCESS && code->expr != NULL
- && code->expr->ts.type != BT_INTEGER)
- gfc_error ("STAT tag in ALLOCATE statement at %L must be "
- "of type INTEGER", &code->expr->where);
-
- for (a = code->ext.alloc_list; a; a = a->next)
- resolve_allocate_expr (a->expr, code);
+ if (t == SUCCESS)
+ resolve_allocate_deallocate (code, "ALLOCATE");
break;
case EXEC_DEALLOCATE:
- if (t == SUCCESS && code->expr != NULL
- && code->expr->ts.type != BT_INTEGER)
- gfc_error
- ("STAT tag in DEALLOCATE statement at %L must be of type "
- "INTEGER", &code->expr->where);
-
- for (a = code->ext.alloc_list; a; a = a->next)
- resolve_deallocate_expr (a->expr);
+ if (t == SUCCESS)
+ resolve_allocate_deallocate (code, "DEALLOCATE");
break;
resolve_branch (code->ext.inquire->err, code);
break;
+ case EXEC_WAIT:
+ if (gfc_resolve_wait (code->ext.wait) == FAILURE)
+ break;
+
+ resolve_branch (code->ext.wait->err, code);
+ resolve_branch (code->ext.wait->end, code);
+ resolve_branch (code->ext.wait->eor, code);
+ break;
+
case EXEC_READ:
case EXEC_WRITE:
if (gfc_resolve_dt (code->ext.dt) == FAILURE)
case EXEC_OMP_ORDERED:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASKWAIT:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_directive (code, ns);
has_error = 1;
}
else if (sym->attr.contained == 0
- && (sym->attr.if_source == IFSRC_UNKNOWN))
- if ((sym->attr.use_assoc
- && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
- || sym->attr.use_assoc == 0)
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ if ((sym->attr.use_assoc && bind_c_sym->mod_name
+ && strcmp (bind_c_sym->mod_name, sym->module) != 0)
+ || sym->attr.use_assoc == 0)
{
gfc_error ("Binding label '%s' at %L collides with global "
"entity '%s' at %L", sym->binding_label,
/* Resolve an index expression. */
-static try
+static gfc_try
resolve_index_expr (gfc_expr *e)
{
if (gfc_resolve_expr (e) == FAILURE)
/* Resolve a charlen structure. */
-static try
+static gfc_try
resolve_charlen (gfc_charlen *cl)
{
int i;
int char_len;
gfc_expr *init_expr;
int i;
- char *ch;
/* These symbols should never have a default initialization. */
if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as))
{
char_len = mpz_get_si (sym->ts.cl->length->value.integer);
init_expr->value.character.length = char_len;
- init_expr->value.character.string = gfc_getmem (char_len+1);
- ch = init_expr->value.character.string;
+ init_expr->value.character.string = gfc_get_wide_string (char_len+1);
for (i = 0; i < char_len; i++)
- *(ch++) = gfc_option.flag_init_character_value;
+ init_expr->value.character.string[i]
+ = (unsigned char) gfc_option.flag_init_character_value;
}
else
{
/* Resolution of common features of flavors variable and procedure. */
-static try
+static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
/* Constraints on deferred shape variable. */
/* Additional checks for symbols with flavor variable and derived
type. To be called from resolve_fl_variable. */
-static try
+static gfc_try
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{
gcc_assert (sym->ts.type == BT_DERIVED);
/* Resolve symbols with flavor variable. */
-static try
+static gfc_try
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
int no_init_flag, automatic_flag;
/* Resolve a procedure. */
-static try
+static gfc_try
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
gfc_formal_arglist *arg;
}
/* 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
+ module procedures are excluded by 2.2.3.3 - i.e., they are not
externally accessible and can access all the objects accessible in
the host. */
if (!(sym->ns->parent
}
}
- if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
+ if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer)
{
gfc_error ("Function '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
}
/* An external symbol may not have an initializer because it is taken to be
- a procedure. */
- if (sym->attr.external && sym->value)
+ a procedure. Exception: Procedure Pointers. */
+ if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
}
}
+ if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
+ "in '%s' at %L", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (sym->attr.intent && !sym->attr.proc_pointer)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
+ "in '%s' at %L", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
return SUCCESS;
}
+/* Resolve a list of finalizer procedures. That is, after they have hopefully
+ been defined and we now know their defined arguments, check that they fulfill
+ the requirements of the standard for procedures used as finalizers. */
+
+static gfc_try
+gfc_resolve_finalizers (gfc_symbol* derived)
+{
+ gfc_finalizer* list;
+ gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
+ gfc_try result = SUCCESS;
+ bool seen_scalar = false;
+
+ if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+ return SUCCESS;
+
+ /* Walk over the list of finalizer-procedures, check them, and if any one
+ does not fit in with the standard's definition, print an error and remove
+ it from the list. */
+ prev_link = &derived->f2k_derived->finalizers;
+ for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
+ {
+ gfc_symbol* arg;
+ gfc_finalizer* i;
+ int my_rank;
+
+ /* Skip this finalizer if we already resolved it. */
+ if (list->proc_tree)
+ {
+ prev_link = &(list->next);
+ continue;
+ }
+
+ /* Check this exists and is a SUBROUTINE. */
+ if (!list->proc_sym->attr.subroutine)
+ {
+ gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
+ list->proc_sym->name, &list->where);
+ goto error;
+ }
+
+ /* We should have exactly one argument. */
+ if (!list->proc_sym->formal || list->proc_sym->formal->next)
+ {
+ gfc_error ("FINAL procedure at %L must have exactly one argument",
+ &list->where);
+ goto error;
+ }
+ arg = list->proc_sym->formal->sym;
+
+ /* This argument must be of our type. */
+ if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
+ &arg->declared_at, derived->name);
+ goto error;
+ }
+
+ /* It must neither be a pointer nor allocatable nor optional. */
+ if (arg->attr.pointer)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
+ &arg->declared_at);
+ goto error;
+ }
+ if (arg->attr.allocatable)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " ALLOCATABLE", &arg->declared_at);
+ goto error;
+ }
+ if (arg->attr.optional)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+ &arg->declared_at);
+ goto error;
+ }
+
+ /* It must not be INTENT(OUT). */
+ if (arg->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " INTENT(OUT)", &arg->declared_at);
+ goto error;
+ }
+
+ /* Warn if the procedure is non-scalar and not assumed shape. */
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ && arg->as->type != AS_ASSUMED_SHAPE)
+ gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
+ " shape argument", &arg->declared_at);
+
+ /* Check that it does not match in kind and rank with a FINAL procedure
+ defined earlier. To really loop over the *earlier* declarations,
+ we need to walk the tail of the list as new ones were pushed at the
+ front. */
+ /* TODO: Handle kind parameters once they are implemented. */
+ my_rank = (arg->as ? arg->as->rank : 0);
+ for (i = list->next; i; i = i->next)
+ {
+ /* Argument list might be empty; that is an error signalled earlier,
+ but we nevertheless continued resolving. */
+ if (i->proc_sym->formal)
+ {
+ gfc_symbol* i_arg = i->proc_sym->formal->sym;
+ const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
+ if (i_rank == my_rank)
+ {
+ gfc_error ("FINAL procedure '%s' declared at %L has the same"
+ " rank (%d) as '%s'",
+ list->proc_sym->name, &list->where, my_rank,
+ i->proc_sym->name);
+ goto error;
+ }
+ }
+ }
+
+ /* Is this the/a scalar finalizer procedure? */
+ if (!arg->as || arg->as->rank == 0)
+ seen_scalar = true;
+
+ /* Find the symtree for this procedure. */
+ gcc_assert (!list->proc_tree);
+ list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
+
+ prev_link = &list->next;
+ continue;
+
+ /* Remove wrong nodes immediately from the list so we don't risk any
+ troubles in the future when they might fail later expectations. */
+error:
+ result = FAILURE;
+ i = list;
+ *prev_link = list->next;
+ gfc_free_finalizer (i);
+ }
+
+ /* Warn if we haven't seen a scalar finalizer procedure (but we know there
+ were nodes in the list, must have been for arrays. It is surely a good
+ idea to have a scalar version there if there's something to finalize. */
+ if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
+ gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
+ " defined at %L, suggest also scalar one",
+ derived->name, &derived->declared_at);
+
+ /* TODO: Remove this error when finalization is finished. */
+ gfc_error ("Finalization at %L is not yet implemented",
+ &derived->declared_at);
+
+ return result;
+}
+
+
+/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
+ to give all identical derived types the same backend_decl. */
+static void
+add_dt_to_dt_list (gfc_symbol *derived)
+{
+ gfc_dt_list *dt_list;
+
+ for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
+ if (derived == dt_list->derived)
+ break;
+
+ if (dt_list == NULL)
+ {
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = gfc_derived_types;
+ dt_list->derived = derived;
+ gfc_derived_types = dt_list;
+ }
+}
+
+
/* Resolve the components of a derived type. */
-static try
+static gfc_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_DERIVED && c->pointer
- && c->ts.derived->components == NULL)
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
+ && c->ts.derived->components == NULL
+ && !c->ts.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
return FAILURE;
}
- if (c->pointer || c->allocatable || c->as == NULL)
+ /* Ensure that all the derived type components are put on the
+ derived type list; even in formal namespaces, where derived type
+ pointer components might not have been declared. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.derived
+ && c->ts.derived->components
+ && c->attr.pointer
+ && sym != c->ts.derived)
+ add_dt_to_dt_list (c->ts.derived);
+
+ if (c->attr.pointer || c->attr.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)
+ || !gfc_is_constant_expr (c->as->lower[i])
|| c->as->upper[i] == NULL
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|| !gfc_is_constant_expr (c->as->upper[i]))
}
}
- /* Add derived type to the derived type list. */
- for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
- if (sym == dt_list->derived)
- break;
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
- if (dt_list == NULL)
- {
- dt_list = gfc_get_dt_list ();
- dt_list->next = gfc_derived_types;
- dt_list->derived = sym;
- gfc_derived_types = dt_list;
- }
+ /* Add derived type to the derived type list. */
+ add_dt_to_dt_list (sym);
return SUCCESS;
}
-static try
+static gfc_try
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
}
-static try
+static gfc_try
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
}
}
- if (sym->attr.procedure && sym->interface
+ if (sym->attr.procedure && sym->ts.interface
&& sym->attr.if_source != IFSRC_DECL)
{
- if (sym->interface->attr.procedure)
+ if (sym->ts.interface->attr.procedure)
gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
- "in a later PROCEDURE statement", sym->interface->name,
+ "in a later PROCEDURE statement", sym->ts.interface->name,
sym->name,&sym->declared_at);
/* Get the attributes from the interface (now resolved). */
- if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
- {
- sym->ts = sym->interface->ts;
- sym->attr.function = sym->interface->attr.function;
- sym->attr.subroutine = sym->interface->attr.subroutine;
- copy_formal_args (sym, sym->interface);
- }
- else if (sym->interface->name[0] != '\0')
+ if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+ {
+ gfc_symbol *ifc = sym->ts.interface;
+ sym->ts = ifc->ts;
+ sym->ts.interface = ifc;
+ sym->attr.function = ifc->attr.function;
+ sym->attr.subroutine = ifc->attr.subroutine;
+ sym->attr.allocatable = ifc->attr.allocatable;
+ sym->attr.pointer = ifc->attr.pointer;
+ sym->attr.pure = ifc->attr.pure;
+ sym->attr.elemental = ifc->attr.elemental;
+ sym->attr.dimension = ifc->attr.dimension;
+ sym->attr.recursive = ifc->attr.recursive;
+ sym->attr.always_explicit = ifc->attr.always_explicit;
+ sym->as = gfc_copy_array_spec (ifc->as);
+ copy_formal_args (sym, ifc);
+ }
+ else if (sym->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
- sym->interface->name, sym->name, &sym->declared_at);
+ sym->ts.interface->name, sym->name, &sym->declared_at);
return;
}
}
type to avoid spurious warnings. */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
{
- if (gfc_intrinsic_name (sym->name, 0))
+ gfc_intrinsic_sym* isym;
+ const char* symstd;
+
+ /* We already know this one is an intrinsic, so we don't call
+ gfc_is_intrinsic for full checking but rather use gfc_find_function and
+ gfc_find_subroutine directly to check whether it is a function or
+ subroutine. */
+
+ if ((isym = gfc_find_function (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
- gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
- sym->name, &sym->declared_at);
+ gfc_warning ("Type specified for intrinsic function '%s' at %L is"
+ " ignored", sym->name, &sym->declared_at);
}
- else if (gfc_intrinsic_name (sym->name, 1))
+ else if ((isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
- sym->name, &sym->declared_at);
+ gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
+ " specifier", sym->name, &sym->declared_at);
return;
}
}
else
{
- gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
+ gfc_error ("'%s' declared INTRINSIC at %L does not exist",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* Check it is actually available in the standard settings. */
+ if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
+ == FAILURE)
+ {
+ gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
+ " available in the current standard settings but %s. Use"
+ " an appropriate -std=* option or enable -fall-intrinsics"
+ " in order to use it.",
+ sym->name, &sym->declared_at, symstd);
return;
}
}
sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
{
- try t = SUCCESS;
+ gfc_try t = SUCCESS;
/* First, make sure the variable is declared at the
module-level scope (J3/04-007, Section 15.3). */
return;
}
+ /* Make sure that the derived type has been resolved and that the
+ derived type is visible in the symbol's namespace, if it is a
+ module function and is not PRIVATE. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.use_assoc
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ gfc_symbol *ds;
+
+ if (resolve_fl_derived (sym->ts.derived) == FAILURE)
+ return;
+
+ gfc_find_symbol (sym->ts.derived->name, sym->ns, 1, &ds);
+ if (!ds && sym->attr.function
+ && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ {
+ symtree = gfc_new_symtree (&sym->ns->sym_root,
+ sym->ts.derived->name);
+ symtree->n.sym = sym->ts.derived;
+ sym->ts.derived->refs++;
+ }
+ }
+
/* Unless the derived-type declaration is use associated, Fortran 95
does not allow public entries of private derived types.
See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
161 in 95-006r3. */
if (sym->ts.type == BT_DERIVED
+ && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && !sym->ts.derived->attr.use_assoc
&& gfc_check_access (sym->attr.access, sym->ns->default_access)
&& !gfc_check_access (sym->ts.derived->attr.access,
sym->ts.derived->ns->default_access)
- && !sym->ts.derived->attr.use_assoc
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
"of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
/* Advance the values structure to point to the next value in the data list. */
-static try
+static gfc_try
next_data_value (void)
{
}
-static try
+static gfc_try
check_data_variable (gfc_data_variable *var, locus *where)
{
gfc_expr *e;
mpz_t size;
mpz_t offset;
- try t;
+ gfc_try t;
ar_type mark = AR_UNKNOWN;
int i;
mpz_t section_index[GFC_MAX_DIMENSIONS];
}
-static try traverse_data_var (gfc_data_variable *, locus *);
+static gfc_try traverse_data_var (gfc_data_variable *, locus *);
/* Iterate over a list of elements in a DATA statement. */
-static try
+static gfc_try
traverse_data_list (gfc_data_variable *var, locus *where)
{
mpz_t trip;
iterator_stack frame;
gfc_expr *e, *start, *end, *step;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
mpz_init (frame.value);
/* Type resolve variables in the variable list of a DATA statement. */
-static try
+static gfc_try
traverse_data_var (gfc_data_variable *var, locus *where)
{
- try t;
+ gfc_try t;
for (; var; var = var->next)
{
This is separate from the assignment checking because data lists should
only be resolved once. */
-static try
+static gfc_try
resolve_data_variables (gfc_data_variable *d)
{
for (; d; d = d->next)
is storage associated with any such variable, shall not be used in the
following contexts: (clients of this function). */
-/* Determines if a variable is not 'pure', ie not assignable within a pure
+/* Determines if a variable is not 'pure', i.e., not assignable within a pure
procedure. Returns zero if assignment is OK, nonzero if there is a
problem. */
int
/* Resolve derived type EQUIVALENCE object. */
-static try
+static gfc_try
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
{
gfc_symbol *d;
return FAILURE;
}
+ if (sym->attr.in_common && has_default_initializer (sym->ts.derived))
+ {
+ gfc_error ("Derived type variable '%s' at %L with default "
+ "initialization cannot be in EQUIVALENCE with a variable "
+ "in COMMON", sym->name, &e->where);
+ return FAILURE;
+ }
+
for (; c ; c = c->next)
{
d = c->ts.derived;
/* Shall not be an object of sequence derived type containing a pointer
in the structure. */
- if (c->pointer)
+ if (c->attr.pointer)
{
gfc_error ("Derived type variable '%s' at %L with pointer "
"component(s) cannot be an EQUIVALENCE object",
sym = e->symtree->n.sym;
- if (sym->attr.protected)
+ if (sym->attr.is_protected)
cnt_protected++;
if (cnt_protected > 0 && cnt_protected != object)
{
gfc_resolve_uops (symtree->left);
gfc_resolve_uops (symtree->right);
- for (itr = symtree->n.uop->operator; itr; itr = itr->next)
+ for (itr = symtree->n.uop->op; itr; itr = itr->next)
{
sym = itr->sym;
if (!sym->attr.function)
resolve_entries (ns);
+ resolve_common_vars (ns->blank_common.head, false);
resolve_common_blocks (ns->common_root);
resolve_contained_functions (ns);
OSDN Git Service
