/* Perform type resolution on the various structures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
}
+static void resolve_symbol (gfc_symbol *sym);
+static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
+
+
+/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
+
+static gfc_try
+resolve_procedure_interface (gfc_symbol *sym)
+{
+ if (sym->ts.interface == sym)
+ {
+ gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ if (sym->ts.interface->attr.procedure)
+ {
+ gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
+ "in a later PROCEDURE statement", sym->ts.interface->name,
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Get the attributes from the interface (now resolved). */
+ if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+ {
+ gfc_symbol *ifc = sym->ts.interface;
+ resolve_symbol (ifc);
+
+ if (ifc->attr.intrinsic)
+ resolve_intrinsic (ifc, &ifc->declared_at);
+
+ if (ifc->result)
+ sym->ts = ifc->result->ts;
+ else
+ sym->ts = ifc->ts;
+ sym->ts.interface = ifc;
+ sym->attr.function = ifc->attr.function;
+ sym->attr.subroutine = ifc->attr.subroutine;
+ gfc_copy_formal_args (sym, ifc);
+
+ 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.contiguous = ifc->attr.contiguous;
+ sym->attr.recursive = ifc->attr.recursive;
+ sym->attr.always_explicit = ifc->attr.always_explicit;
+ sym->attr.ext_attr |= ifc->attr.ext_attr;
+ sym->attr.is_bind_c = ifc->attr.is_bind_c;
+ /* Copy array spec. */
+ sym->as = gfc_copy_array_spec (ifc->as);
+ if (sym->as)
+ {
+ int i;
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ gfc_expr_replace_symbols (sym->as->lower[i], sym);
+ gfc_expr_replace_symbols (sym->as->upper[i], sym);
+ }
+ }
+ /* Copy char length. */
+ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
+ {
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+ gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
+ if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
+ && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
+ return FAILURE;
+ }
+ }
+ else if (sym->ts.interface->name[0] != '\0')
+ {
+ gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
+ sym->ts.interface->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
&proc->declared_at);
continue;
}
+ else if (sym->attr.procedure && sym->ts.interface
+ && sym->attr.if_source != IFSRC_DECL)
+ resolve_procedure_interface (sym);
if (sym->attr.if_source != IFSRC_UNKNOWN)
resolve_formal_arglist (sym);
continue;
}
+ if (proc->attr.implicit_pure && !gfc_pure(sym))
+ proc->attr.implicit_pure = 0;
+
if (gfc_elemental (proc))
{
gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
continue;
}
- if (sym->ts.type == BT_UNKNOWN)
- {
- if (!sym->attr.function || sym->result == sym)
- gfc_set_default_type (sym, 1, sym->ns);
- }
+ if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
+ && (!sym->attr.function || sym->result == sym))
+ gfc_set_default_type (sym, 1, sym->ns);
gfc_resolve_array_spec (sym->as, 0);
&sym->declared_at);
}
+ if (proc->attr.implicit_pure && !sym->attr.pointer
+ && sym->attr.flavor != FL_PROCEDURE)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ proc->attr.implicit_pure = 0;
+
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ proc->attr.implicit_pure = 0;
+ }
+
if (gfc_elemental (proc))
{
/* F2008, C1289. */
continue;
}
+ if (sym->attr.allocatable)
+ {
+ gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+ "have the ALLOCATABLE attribute", sym->name,
+ &sym->declared_at);
+ continue;
+ }
+
if (sym->attr.pointer)
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
&sym->declared_at);
continue;
}
+
+ if (sym->attr.intent == INTENT_UNKNOWN)
+ {
+ gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
+ "have its INTENT specified", sym->name, proc->name,
+ &sym->declared_at);
+ continue;
+ }
}
/* Each dummy shall be specified to be scalar. */
/* Resolve all of the elements of a structure constructor and make sure that
- the types are correct. */
+ the types are correct. The 'init' flag indicates that the given
+ constructor is an initializer. */
static gfc_try
-resolve_structure_cons (gfc_expr *expr)
+resolve_structure_cons (gfc_expr *expr, int init)
{
gfc_constructor *cons;
gfc_component *comp;
symbol_attribute a;
t = SUCCESS;
+
+ if (expr->ts.type == BT_DERIVED)
+ resolve_symbol (expr->ts.u.derived);
+
cons = gfc_constructor_first (expr->value.constructor);
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
/* If we don't have the right type, try to convert it. */
- if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
+ if (!comp->attr.proc_pointer &&
+ !gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (strcmp (comp->name, "$extends") == 0)
+ if (strcmp (comp->name, "_extends") == 0)
{
- /* Can afford to be brutal with the $extends initializer.
+ /* Can afford to be brutal with the _extends initializer.
The derived type can get lost because it is PRIVATE
but it is not usage constrained by the standard. */
cons->expr->ts = comp->ts;
comp->name);
}
- if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
+ if (!comp->attr.pointer || comp->attr.proc_pointer
+ || cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
"a TARGET", &cons->expr->where, comp->name);
}
+ if (init)
+ {
+ /* F08:C461. Additional checks for pointer initialization. */
+ if (a.allocatable)
+ {
+ t = FAILURE;
+ gfc_error ("Pointer initialization target at %L "
+ "must not be ALLOCATABLE ", &cons->expr->where);
+ }
+ if (!a.save)
+ {
+ t = FAILURE;
+ gfc_error ("Pointer initialization target at %L "
+ "must have the SAVE attribute", &cons->expr->where);
+ }
+ }
+
/* F2003, C1272 (3). */
if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (cons->expr->symtree->n.sym)
"pointer component '%s' at %L in PURE procedure",
comp->name, &cons->expr->where);
}
+
+ if (gfc_implicit_pure (NULL)
+ && cons->expr->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
}
return t;
static gfc_try
resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
- gfc_intrinsic_sym* isym;
+ gfc_intrinsic_sym* isym = NULL;
const char* symstd;
if (sym->formal)
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
- if ((isym = gfc_find_function (sym->name)))
+ if (sym->intmod_sym_id)
+ isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
+ else
+ isym = gfc_find_function (sym->name);
+
+ if (isym)
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
- gfc_component *comp;
for (; arg; arg = arg->next)
{
continue;
}
- if (gfc_is_proc_ptr_comp (e, &comp))
- {
- e->ts = comp->ts;
- if (e->expr_type == EXPR_PPC)
- {
- if (comp->as != NULL)
- e->rank = comp->as->rank;
- e->expr_type = EXPR_FUNCTION;
- }
- if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
- goto argument_list;
- }
-
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
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 (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: Internal procedure '%s' is"
+ " used as actual argument at %L",
+ sym->name, &e->where) == FAILURE)
+ return FAILURE;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
}
-/* Go through each actual argument in ACTUAL and see if it can be
- implemented as an inlined, non-copying intrinsic. FNSYM is the
- function being called, or NULL if not known. */
-
-static void
-find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
-{
- gfc_actual_arglist *ap;
- gfc_expr *expr;
-
- for (ap = actual; ap; ap = ap->next)
- if (ap->expr
- && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
- && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
- NOT_ELEMENTAL))
- 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
switch (ref->type)
{
case REF_SUBSTRING:
- if (ref->u.ss.length != NULL
- && ref->u.ss.length->length != NULL
- && ref->u.ss.start
- && ref->u.ss.start->expr_type == EXPR_CONSTANT
- && ref->u.ss.end
- && ref->u.ss.end->expr_type == EXPR_CONSTANT)
- {
- start = (int) mpz_get_si (ref->u.ss.start->value.integer);
- end = (int) mpz_get_si (ref->u.ss.end->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
- else
- retval = FAILURE;
+ if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
+ || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
+ retval = FAILURE;
break;
+
case REF_ARRAY:
if (ref->u.ar.type == AR_ELEMENT)
retval = SUCCESS;
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
- scalar. */
+ scalar.
+ FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
end = (int) mpz_get_si
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
-/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
- to INTENT(OUT) or INTENT(INOUT). */
static gfc_try
resolve_function (gfc_expr *expr)
}
}
+ if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
}
- 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);
-
/* Make sure that the expression has a typespec that works. */
if (expr->ts.type == BT_UNKNOWN)
{
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
- if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
- find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
else
- sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ {
+ sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
+ e->value.op.uop->name, gfc_typename (&op1->ts),
+ gfc_typename (&op2->ts));
+ e->value.op.uop->op->sym->attr.referenced = 1;
+ }
goto bad_op;
if (e->symtree == NULL)
return FAILURE;
+ sym = e->symtree->n.sym;
+
+ /* If this is an associate-name, it may be parsed with an array reference
+ in error even though the target is scalar. Fail directly in this case. */
+ if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
+ return FAILURE;
+
+ /* On the other hand, the parser may not have known this is an array;
+ in this case, we have to add a FULL reference. */
+ if (sym->assoc && sym->attr.dimension && !e->ref)
+ {
+ e->ref = gfc_get_ref ();
+ e->ref->type = REF_ARRAY;
+ e->ref->u.ar.type = AR_FULL;
+ e->ref->u.ar.dimen = 0;
+ }
if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE;
- sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE
&& (!sym->attr.function
|| (sym->attr.function && sym->result
{
gfc_ref *ref, *ref2 = NULL;
- if (e->ts.type == BT_CLASS)
- {
- gfc_error ("Polymorphic subobject of coindexed object at %L",
- &e->where);
- t = FAILURE;
- }
-
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT)
if (ref->type == REF_COMPONENT)
break;
+ /* Expression itself is not coindexed object. */
+ if (ref && e->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic subobject of coindexed object at %L",
+ &e->where);
+ t = FAILURE;
+ }
+
/* Expression itself is coindexed object. */
if (ref == NULL)
{
if (!po)
return FAILURE;
+ /* F08:R739. */
if (po->rank > 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
}
+ /* F08:C611. */
+ if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
+ {
+ gfc_error ("Base object for procedure-pointer component call at %L is of"
+ " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
+ return FAILURE;
+ }
+
gcc_assert (tb->pass_arg_num > 0);
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
tb->pass_arg_num,
check_typebound_baseobject (gfc_expr* e)
{
gfc_expr* base;
+ gfc_try return_value = FAILURE;
base = extract_compcall_passed_object (e);
if (!base)
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+ /* F08:C611. */
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
- return FAILURE;
+ goto cleanup;
}
- /* If the procedure called is NOPASS, the base object must be scalar. */
+ /* F08:C1230. If the procedure called is NOPASS,
+ the base object must be scalar. */
if (e->value.compcall.tbp->nopass && base->rank > 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
" be scalar", &e->where);
- return FAILURE;
+ goto cleanup;
}
- /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
+ /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
if (base->rank > 0)
{
gfc_error ("Non-scalar base object at %L currently not implemented",
&e->where);
- return FAILURE;
+ goto cleanup;
}
- return SUCCESS;
+ return_value = SUCCESS;
+
+cleanup:
+ gfc_free_expr (base);
+ return return_value;
}
/* Deal with typebound operators for CLASS objects. */
expr = e->value.compcall.base_object;
- if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
- && e->value.compcall.name)
+ if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
- ts = expr->symtree->n.sym->ts;
+ ts = expr->ts;
declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
/* Use the generic name if it is there. */
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
- expr->symtree->n.sym->ts.u.derived = declared;
- gfc_add_component_ref (e, "$vptr");
+ e->ref = gfc_copy_ref (expr->ref);
+ gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
return SUCCESS;
return resolve_compcall (e, NULL);
}
- c = gfc_find_component (declared, "$data", true, true);
+ c = gfc_find_component (declared, "_data", true, true);
declared = c->ts.u.derived;
/* Treat the call as if it is a typebound procedure, in order to roll
if (new_ref)
e->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (e, "$vptr");
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
/* Recover the typespec for the expression. This is really only
is present. */
ts = expr->symtree->n.sym->ts;
declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
expr->symtree->n.sym->ts.u.derived = declared;
- gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
return SUCCESS;
if (new_ref)
code->expr1->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (code->expr1, "$vptr");
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
/* Recover the typespec for the expression. This is really only
if (t == FAILURE)
break;
- t = resolve_structure_cons (e);
+ t = resolve_structure_cons (e, 0);
if (t == FAILURE)
break;
== FAILURE)
return FAILURE;
- if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
- {
- gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
- &iter->var->where);
- return FAILURE;
- }
+ if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+ == FAILURE)
+ return FAILURE;
if (gfc_resolve_iterator_expr (iter->start, real_ok,
"Start expression in DO loop") == FAILURE)
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
- int allocatable, pointer, check_intent_in;
+ int allocatable, pointer;
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *c;
- /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
- check_intent_in = 1;
-
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
}
for (ref = e->ref; ref; ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
return FAILURE;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
- return FAILURE;
- }
-
- if (e->ts.type == BT_CLASS)
- {
- /* Only deallocate the DATA component. */
- gfc_add_component_ref (e, "$data");
- }
+ if (pointer
+ && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+ return FAILURE;
+ if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+ return FAILURE;
return SUCCESS;
}
}
+/* If the last ref of an expression is an array ref, return a copy of the
+ expression with that one removed. Otherwise, a copy of the original
+ expression. This is used for allocate-expressions and pointer assignment
+ LHS, where there may be an array specification that needs to be stripped
+ off when using gfc_check_vardef_context. */
+
+static gfc_expr*
+remove_last_array_ref (gfc_expr* e)
+{
+ gfc_expr* e2;
+ gfc_ref** r;
+
+ e2 = gfc_copy_expr (e);
+ for (r = &e2->ref; *r; r = &(*r)->next)
+ if ((*r)->type == REF_ARRAY && !(*r)->next)
+ {
+ gfc_free_ref_list (*r);
+ *r = NULL;
+ break;
+ }
+
+ return e2;
+}
+
+
/* Used in resolve_allocate_expr to check that a allocation-object and
a source-expr are conformable. This does not catch all possible
cases; in particular a runtime checking is needed. */
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int i, pointer, allocatable, dimension, is_abstract;
int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
+ gfc_expr *e2;
gfc_array_ref *ar;
gfc_symbol *sym = NULL;
gfc_alloc *a;
gfc_component *c;
-
- /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
- check_intent_in = 1;
+ gfc_try t;
/* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
checking of coarrays. */
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
goto failure;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
- goto failure;
- }
-
- if (!code->expr3 || code->expr3->mold)
+ /* In the variable definition context checks, gfc_expr_attr is used
+ on the expression. This is fooled by the array specification
+ present in e, thus we have to eliminate that one temporarily. */
+ e2 = remove_last_array_ref (e);
+ t = SUCCESS;
+ if (t == SUCCESS && pointer)
+ t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+ gfc_free_expr (e2);
+ if (t == FAILURE)
+ goto failure;
+
+ if (!code->expr3)
{
- /* Add default initializer for those derived types that need them. */
- gfc_expr *init_e = NULL;
+ /* Set up default initializer if needed. */
gfc_typespec ts;
+ gfc_expr *init_e;
if (code->ext.alloc.ts.type == BT_DERIVED)
ts = code->ext.alloc.ts;
- else if (code->expr3)
- ts = code->expr3->ts;
else
ts = e->ts;
- if (ts.type == BT_DERIVED)
- init_e = gfc_default_initializer (&ts);
- /* FIXME: Use default init of dynamic type (cf. PR 44541). */
- else if (e->ts.type == BT_CLASS)
- init_e = gfc_default_initializer (&ts.u.derived->components->ts);
+ if (ts.type == BT_CLASS)
+ ts = ts.u.derived->components->ts;
- if (init_e)
+ if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts)))
{
gfc_code *init_st = gfc_get_code ();
init_st->loc = code->loc;
code->next = init_st;
}
}
+ else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
+ {
+ /* Default initialization via MOLD (non-polymorphic). */
+ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
+ gfc_resolve_expr (rhs);
+ gfc_free_expr (code->expr3);
+ code->expr3 = rhs;
+ }
if (e->ts.type == BT_CLASS)
{
if (pointer || (dimension == 0 && codimension == 0))
goto success;
- /* Make sure the next-to-last reference node is an array specification. */
+ /* Make sure the last reference node is an array specifiction. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
}
success:
+ if (e->ts.deferred)
+ {
+ gfc_error ("Support for entity at %L with deferred type parameter "
+ "not yet implemented", &e->where);
+ return FAILURE;
+ }
return SUCCESS;
failure:
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
- stat = code->expr1 ? code->expr1 : NULL;
-
- errmsg = code->expr2 ? code->expr2 : NULL;
+ stat = code->expr1;
+ errmsg = code->expr2;
/* Check the stat variable. */
if (stat)
{
- if (stat->symtree->n.sym->attr.intent == INTENT_IN)
- gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
- stat->symtree->n.sym->name, &stat->where);
-
- if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
- gfc_error ("Illegal stat-variable at %L for a PURE procedure",
- &stat->where);
+ gfc_check_vardef_context (stat, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
- gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
- errmsg->symtree->n.sym->name, &errmsg->where);
-
- if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
- gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
- &errmsg->where);
+ gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
- if ((pe->ref && pe->ref->type != REF_COMPONENT)
- && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+ for (q = p->next; q; q = q->next)
{
- for (q = p->next; q; q = q->next)
+ qe = q->expr;
+ if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
{
- qe = q->expr;
- if ((qe->ref && qe->ref->type != REF_COMPONENT)
- && (qe->symtree->n.sym->ts.type != BT_DERIVED)
- && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
- gfc_error ("Allocate-object at %L also appears at %L",
- &pe->where, &qe->where);
+ /* This is a potential collision. */
+ gfc_ref *pr = pe->ref;
+ gfc_ref *qr = qe->ref;
+
+ /* Follow the references until
+ a) They start to differ, in which case there is no error;
+ you can deallocate a%b and a%c in a single statement
+ b) Both of them stop, which is an error
+ c) One of them stops, which is also an error. */
+ while (1)
+ {
+ if (pr == NULL && qr == NULL)
+ {
+ gfc_error ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
+ break;
+ }
+ else if (pr != NULL && qr == NULL)
+ {
+ gfc_error ("Allocate-object at %L is subobject of"
+ " object at %L", &pe->where, &qe->where);
+ break;
+ }
+ else if (pr == NULL && qr != NULL)
+ {
+ gfc_error ("Allocate-object at %L is subobject of"
+ " object at %L", &qe->where, &pe->where);
+ break;
+ }
+ /* Here, pr != NULL && qr != NULL */
+ gcc_assert(pr->type == qr->type);
+ if (pr->type == REF_ARRAY)
+ {
+ /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
+ which are legal. */
+ gcc_assert (qr->type == REF_ARRAY);
+
+ if (pr->next && qr->next)
+ {
+ gfc_array_ref *par = &(pr->u.ar);
+ gfc_array_ref *qar = &(qr->u.ar);
+ if (gfc_dep_compare_expr (par->start[0],
+ qar->start[0]) != 0)
+ break;
+ }
+ }
+ else
+ {
+ if (pr->u.c.component->name != qr->u.c.component->name)
+ break;
+ }
+
+ pr = pr->next;
+ qr = qr->next;
+ }
}
}
}
if (type == BT_INTEGER)
for (body = code->block; body; body = body->block)
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
if (cp->low
&& gfc_check_integer_range (cp->low->value.integer,
for (body = code->block; body; body = body->block)
{
/* Walk the case label list. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Intercept the DEFAULT case. It does not have a kind. */
if (cp->low == NULL && cp->high == NULL)
/* Walk the case label list, making sure that all case labels
are legal. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Count the number of cases in the whole construct. */
ncases++;
if (seen_unreachable)
{
/* Advance until the first case in the list is reachable. */
- while (body->ext.case_list != NULL
- && body->ext.case_list->unreachable)
+ while (body->ext.block.case_list != NULL
+ && body->ext.block.case_list->unreachable)
{
- gfc_case *n = body->ext.case_list;
- body->ext.case_list = body->ext.case_list->next;
+ gfc_case *n = body->ext.block.case_list;
+ body->ext.block.case_list = body->ext.block.case_list->next;
n->next = NULL;
gfc_free_case_list (n);
}
/* Strip all other unreachable cases. */
- if (body->ext.case_list)
+ if (body->ext.block.case_list)
{
- for (cp = body->ext.case_list; cp->next; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
{
if (cp->next->unreachable)
{
unreachable case labels for a block. */
for (body = code; body && body->block; body = body->block)
{
- if (body->block->ext.case_list == NULL)
+ if (body->block->ext.block.case_list == NULL)
{
/* Cut the unreachable block from the code chain. */
gfc_code *c = body->block;
}
+/* Resolve an associate name: Resolve target and ensure the type-spec is
+ correct as well as possibly the array-spec. */
+
+static void
+resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
+{
+ gfc_expr* target;
+
+ gcc_assert (sym->assoc);
+ gcc_assert (sym->attr.flavor == FL_VARIABLE);
+
+ /* If this is for SELECT TYPE, the target may not yet be set. In that
+ case, return. Resolution will be called later manually again when
+ this is done. */
+ target = sym->assoc->target;
+ if (!target)
+ return;
+ gcc_assert (!sym->assoc->dangling);
+
+ if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
+ return;
+
+ /* For variable targets, we get some attributes from the target. */
+ if (target->expr_type == EXPR_VARIABLE)
+ {
+ gfc_symbol* tsym;
+
+ gcc_assert (target->symtree);
+ tsym = target->symtree->n.sym;
+
+ sym->attr.asynchronous = tsym->attr.asynchronous;
+ sym->attr.volatile_ = tsym->attr.volatile_;
+
+ sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+ }
+
+ /* Get type if this was not already set. Note that it can be
+ some other type than the target in case this is a SELECT TYPE
+ selector! So we must not update when the type is already there. */
+ if (sym->ts.type == BT_UNKNOWN)
+ sym->ts = target->ts;
+ gcc_assert (sym->ts.type != BT_UNKNOWN);
+
+ /* See if this is a valid association-to-variable. */
+ sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
+ && !gfc_has_vector_subscript (target));
+
+ /* Finally resolve if this is an array or not. */
+ if (sym->attr.dimension && target->rank == 0)
+ {
+ gfc_error ("Associate-name '%s' at %L is used as array",
+ sym->name, &sym->declared_at);
+ sym->attr.dimension = 0;
+ return;
+ }
+ if (target->rank > 0)
+ sym->attr.dimension = 1;
+
+ if (sym->attr.dimension)
+ {
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = target->rank;
+ sym->as->type = AS_DEFERRED;
+
+ /* Target must not be coindexed, thus the associate-variable
+ has no corank. */
+ sym->as->corank = 0;
+ }
+}
+
+
/* Resolve a SELECT TYPE statement. */
static void
-resolve_select_type (gfc_code *code)
+resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
gfc_symbol *selector_type;
gfc_code *body, *new_st, *if_st, *tail;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
- &default_case->ext.case_list->where, &c->where);
+ &default_case->ext.block.case_list->where, &c->where);
error++;
continue;
}
- else
- default_case = body;
+
+ default_case = body;
}
}
- if (error>0)
+ if (error > 0)
return;
+ /* Transform SELECT TYPE statement to BLOCK and associate selector to
+ target if present. If there are any EXIT statements referring to the
+ SELECT TYPE construct, this is no problem because the gfc_code
+ reference stays the same and EXIT is equally possible from the BLOCK
+ it is changed to. */
+ code->op = EXEC_BLOCK;
if (code->expr2)
{
- /* Insert assignment for selector variable. */
- new_st = gfc_get_code ();
- new_st->op = EXEC_ASSIGN;
- new_st->expr1 = gfc_copy_expr (code->expr1);
- new_st->expr2 = gfc_copy_expr (code->expr2);
- ns->code = new_st;
+ gfc_association_list* assoc;
+
+ assoc = gfc_get_association_list ();
+ assoc->st = code->expr1->symtree;
+ assoc->target = gfc_copy_expr (code->expr2);
+ /* assoc->variable will be set by resolve_assoc_var. */
+
+ code->ext.block.assoc = assoc;
+ code->expr1->symtree->n.sym->assoc = assoc;
+
+ resolve_assoc_var (code->expr1->symtree->n.sym, false);
}
+ else
+ code->ext.block.assoc = NULL;
- /* Put SELECT TYPE statement inside a BLOCK. */
+ /* Add EXEC_SELECT to switch on type. */
new_st = gfc_get_code ();
new_st->op = code->op;
new_st->expr1 = code->expr1;
new_st->expr2 = code->expr2;
new_st->block = code->block;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
if (!ns->code)
ns->code = new_st;
else
ns->code->next = new_st;
- code->op = EXEC_BLOCK;
- code->ext.block.assoc = NULL;
- code->expr1 = code->expr2 = NULL;
- code->block = NULL;
-
code = new_st;
-
- /* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
- gfc_add_component_ref (code->expr1, "$vptr");
- gfc_add_component_ref (code->expr1, "$hash");
+ gfc_add_vptr_component (code->expr1);
+ gfc_add_hash_component (code->expr1);
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
else if (c->ts.type == BT_UNKNOWN)
continue;
- /* Assign temporary to selector. */
+ /* Associate temporary to selector. This should only be done
+ when this case is actually true, so build a new ASSOCIATE
+ that does precisely this here (instead of using the
+ 'global' one). */
+
if (c->ts.type == BT_CLASS)
- sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+ sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
else
- sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
+ sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
st = gfc_find_symtree (ns->sym_root, name);
- new_st = gfc_get_code ();
- new_st->expr1 = gfc_get_variable_expr (st);
- new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
+ gcc_assert (st->n.sym->assoc);
+ st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
if (c->ts.type == BT_DERIVED)
+ gfc_add_data_component (st->n.sym->assoc->target);
+
+ new_st = gfc_get_code ();
+ new_st->op = EXEC_BLOCK;
+ new_st->ext.block.ns = gfc_build_block_ns (ns);
+ new_st->ext.block.ns->code = body->next;
+ body->next = new_st;
+
+ /* Chain in the new list only if it is marked as dangling. Otherwise
+ there is a CASE label overlap and this is already used. Just ignore,
+ the error is diagonsed elsewhere. */
+ if (st->n.sym->assoc->dangling)
{
- new_st->op = EXEC_POINTER_ASSIGN;
- gfc_add_component_ref (new_st->expr2, "$data");
+ new_st->ext.block.assoc = st->n.sym->assoc;
+ st->n.sym->assoc->dangling = 0;
}
- else
- new_st->op = EXEC_POINTER_ASSIGN;
- new_st->next = body->next;
- body->next = new_st;
+
+ resolve_assoc_var (st->n.sym, false);
}
/* Take out CLASS IS cases for separate treatment. */
body = code;
while (body && body->block)
{
- if (body->block->ext.case_list->ts.type == BT_CLASS)
+ if (body->block->ext.block.case_list->ts.type == BT_CLASS)
{
/* Add to class_is list. */
if (class_is == NULL)
tail->block = gfc_get_code ();
tail = tail->block;
tail->op = EXEC_SELECT_TYPE;
- tail->ext.case_list = gfc_get_case ();
- tail->ext.case_list->ts.type = BT_UNKNOWN;
+ tail->ext.block.case_list = gfc_get_case ();
+ tail->ext.block.case_list->ts.type = BT_UNKNOWN;
tail->next = NULL;
default_case = tail;
}
{
c2 = (*c1)->block;
/* F03:C817 (check for doubles). */
- if ((*c1)->ext.case_list->ts.u.derived->hash_value
- == c2->ext.case_list->ts.u.derived->hash_value)
+ if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
+ == c2->ext.block.case_list->ts.u.derived->hash_value)
{
gfc_error ("Double CLASS IS block in SELECT TYPE "
- "statement at %L", &c2->ext.case_list->where);
+ "statement at %L",
+ &c2->ext.block.case_list->where);
return;
}
- if ((*c1)->ext.case_list->ts.u.derived->attr.extension
- < c2->ext.case_list->ts.u.derived->attr.extension)
+ if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
+ < c2->ext.block.case_list->ts.u.derived->attr.extension)
{
/* Swap. */
(*c1)->block = c2->block;
/* Set up arguments. */
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
- gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
- vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+ new_st->expr1->value.function.actual->expr->where = code->loc;
+ gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
+ vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
default_case->next = if_st;
}
- resolve_select (code);
+ /* Resolve the internal code. This can not be done earlier because
+ it requires that the sym->assoc of selectors is set already. */
+ gfc_current_ns = ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = old_ns;
+ resolve_select (code);
}
exp = code->expr1;
- if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
+ while (exp != NULL && exp->expr_type == EXPR_OP
+ && exp->value.op.op == INTRINSIC_PARENTHESES)
+ exp = exp->value.op.op1;
+
+ if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
+ && exp->expr_type != EXPR_FUNCTION))
+ return;
+
+ /* If we are reading, the variable will be changed. Note that
+ code->ext.dt may be NULL if the TRANSFER is related to
+ an INQUIRE statement -- but in this case, we are not reading, either. */
+ if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
+ && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
return;
sym = exp->symtree->n.sym;
ts = &sym->ts;
/* Go to actual component transferred. */
- for (ref = code->expr1->ref; ref; ref = ref->next)
+ for (ref = exp->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
+ if (ts->type == BT_CLASS)
+ {
+ /* FIXME: Test for defined input/output. */
+ gfc_error ("Data transfer element at %L cannot be polymorphic unless "
+ "it is processed by a defined input/output procedure",
+ &code->loc);
+ return;
+ }
+
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
static void
resolve_block_construct (gfc_code* code)
{
- /* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during gfc_resolve_symbol. */
-
/* Resolve the BLOCK's namespace. */
gfc_resolve (code->ext.block.ns);
+
+ /* For an ASSOCIATE block, the associations (and their targets) are already
+ resolved during resolve_symbol. */
}
}
}
-
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
if (gfc_pure (NULL))
{
- if (gfc_impure_variable (lhs->symtree->n.sym))
- {
- gfc_error ("Cannot assign to variable '%s' in PURE "
- "procedure at %L",
- lhs->symtree->n.sym->name,
- &lhs->where);
- return rval;
- }
-
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
}
}
+ if (gfc_implicit_pure (NULL))
+ {
+ if (lhs->expr_type == EXPR_VARIABLE
+ && lhs->symtree->n.sym != gfc_current_ns->proc_name
+ && lhs->symtree->n.sym->ns != gfc_current_ns)
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ if (lhs->ts.type == BT_DERIVED
+ && lhs->expr_type == EXPR_VARIABLE
+ && lhs->ts.u.derived->attr.pointer_comp
+ && rhs->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ }
+
/* F03:7.4.1.2. */
/* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
- gfc_current_ns = code->ext.block.ns;
- gfc_resolve_blocks (code->block, gfc_current_ns);
- gfc_current_ns = ns;
+ /* Blocks are handled in resolve_select_type because we have
+ to transform the SELECT TYPE into ASSOCIATE first. */
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
if (t == FAILURE)
break;
+ if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
+ == FAILURE)
+ break;
+
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
break;
case EXEC_POINTER_ASSIGN:
- if (t == FAILURE)
- break;
+ {
+ gfc_expr* e;
- gfc_check_pointer_assign (code->expr1, code->expr2);
- break;
+ if (t == FAILURE)
+ break;
+
+ /* This is both a variable definition and pointer assignment
+ context, so check both of them. For rank remapping, a final
+ array ref may be present on the LHS and fool gfc_expr_attr
+ used in gfc_check_vardef_context. Remove it. */
+ e = remove_last_array_ref (code->expr1);
+ t = gfc_check_vardef_context (e, true, _("pointer assignment"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+ gfc_free_expr (e);
+ if (t == FAILURE)
+ break;
+
+ gfc_check_pointer_assign (code->expr1, code->expr2);
+ break;
+ }
case EXEC_ARITHMETIC_IF:
if (t == SUCCESS
break;
case EXEC_SELECT_TYPE:
- resolve_select_type (code);
+ resolve_select_type (code, ns);
break;
case EXEC_BLOCK:
- gfc_resolve (code->ext.block.ns);
+ resolve_block_construct (code);
break;
case EXEC_DO:
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
- if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
- gfc_error ("FORALL mask clause at %L requires a LOGICAL "
+ if (code->expr1 != NULL
+ && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
+ gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
"expression", &code->expr1->where);
break;
static void
resolve_values (gfc_symbol *sym)
{
+ gfc_try t;
+
if (sym->value == NULL)
return;
- if (gfc_resolve_expr (sym->value) == FAILURE)
+ if (sym->value->expr_type == EXPR_STRUCTURE)
+ t= resolve_structure_cons (sym->value, 1);
+ else
+ t = gfc_resolve_expr (sym->value);
+
+ if (t == FAILURE)
return;
gfc_check_assign_symbol (sym, sym->value);
return SUCCESS;
}
+
/* Resolve a charlen structure. */
static gfc_try
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
init = gfc_default_initializer (&sym->ts);
- if (init == NULL)
+ if (init == NULL && sym->ts.type != BT_CLASS)
return;
build_init_assign (sym, init);
+ sym->attr.referenced = 1;
}
/* Build an initializer for a local integer, real, complex, logical, or
build_init_assign (sym, init);
}
+
/* Resolution of common features of flavors variable and procedure. */
static gfc_try
sym->name, &sym->declared_at);
return FAILURE;
}
-
}
else
{
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
- && !sym->attr.dummy && sym->ts.type != BT_CLASS)
+ && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
}
/* F03:C509. */
- /* Assume that use associated symbols were checked in the module ns. */
- if (!sym->attr.class_ok && !sym->attr.use_assoc)
+ /* Assume that use associated symbols were checked in the module ns.
+ Class-variables that are associate-names are also something special
+ and excepted from the test. */
+ if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
return FAILURE;
}
+ /* Constraints on deferred type parameter. */
+ if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+ "requires either the pointer or allocatable attribute",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (sym->ts.type == BT_CHARACTER)
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
e = sym->ts.u.cl->length;
- if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+ if (e == NULL && !sym->attr.dummy && !sym->attr.result
+ && !sym->ts.deferred)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
return FAILURE;
}
- if (e && sym->attr.save && !gfc_is_constant_expr (e))
+ if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
stree->n.tb->error = 1;
}
+
static gfc_try
resolve_typebound_procedures (gfc_symbol* derived)
{
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
+ /* Make sure the vtab has been generated. */
+ gfc_find_derived_vtab (derived);
+
if (derived->f2k_derived->tb_sym_root)
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
&resolve_typebound_procedure);
for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
if (derived == dt_list->derived)
- break;
+ return;
- 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;
- }
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = gfc_derived_types;
+ dt_list->derived = derived;
+ gfc_derived_types = dt_list;
}
}
-static void resolve_symbol (gfc_symbol *sym);
-
-
/* Resolve the components of a derived type. */
static gfc_try
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
- gfc_component *data = gfc_find_component (sym, "$data", true, true);
- gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
+ gfc_component *data = gfc_find_component (sym, "_data", true, true);
+ gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
if (vptr->ts.u.derived == NULL)
{
gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
}
/* Check type-spec if this is not the parent-type component. */
- if ((!sym->attr.extension || c != sym->components)
+ if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
return FAILURE;
sym->name, &sym->declared_at) == FAILURE)
return FAILURE;
+ if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
+ "type %s", c->name, &c->loc, sym->name);
+ return FAILURE;
+ }
+
if (sym->attr.sequence)
{
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
}
}
- if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
- && c->ts.u.derived->components == NULL
+ if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
+ && c->attr.pointer && c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
gfc_namelist *nl;
gfc_symbol *nlsym;
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ /* Reject namelist arrays of assumed shape. */
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
+ && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
+ "must not have assumed shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* Reject namelist arrays that are not constant shape. */
+ if (is_non_constant_shape_array (nl->sym))
+ {
+ gfc_error ("NAMELIST array object '%s' must have constant "
+ "shape in namelist '%s' at %L", nl->sym->name,
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* Namelist objects cannot have allocatable or pointer components. */
+ if (nl->sym->ts.type != BT_DERIVED)
+ continue;
+
+ if (nl->sym->ts.u.derived->attr.alloc_comp)
+ {
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
+ "have ALLOCATABLE components",
+ nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (nl->sym->ts.u.derived->attr.pointer_comp)
+ {
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
+ "have POINTER components",
+ nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
/* 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)
- {
- /* Reject namelist arrays of assumed shape. */
- if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
- "must not have assumed shape in namelist "
- "'%s' at %L", nl->sym->name, sym->name,
- &sym->declared_at) == FAILURE)
- return FAILURE;
-
- /* Reject namelist arrays that are not constant shape. */
- if (is_non_constant_shape_array (nl->sym))
- {
- gfc_error ("NAMELIST array object '%s' must have constant "
- "shape in namelist '%s' at %L", nl->sym->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- /* Namelist objects cannot have allocatable or pointer components. */
- if (nl->sym->ts.type != BT_DERIVED)
- continue;
-
- if (nl->sym->ts.u.derived->attr.alloc_comp)
- {
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have ALLOCATABLE components",
- nl->sym->name, sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- if (nl->sym->ts.u.derived->attr.pointer_comp)
- {
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have POINTER components",
- nl->sym->name, 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. */
gfc_component *c;
/* Avoid double resolution of function result symbols. */
- if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
+ if ((sym->result || sym->attr.result) && !sym->attr.dummy
+ && (sym->ns != gfc_current_ns))
return;
if (sym->attr.flavor == FL_UNKNOWN)
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
{
symtree = gfc_find_symtree (ns->sym_root, sym->name);
- if (symtree && symtree->n.sym->generic)
+ if (symtree && (symtree->n.sym->generic ||
+ (symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && sym->ns->construct_entities)))
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
if (sym->attr.procedure && sym->ts.interface
- && sym->attr.if_source != IFSRC_DECL)
- {
- if (sym->ts.interface == sym)
- {
- gfc_error ("PROCEDURE '%s' at %L may not be used as its own "
- "interface", sym->name, &sym->declared_at);
- return;
- }
- if (sym->ts.interface->attr.procedure)
- {
- gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared"
- " in a later PROCEDURE statement", sym->ts.interface->name,
- sym->name,&sym->declared_at);
- return;
- }
-
- /* Get the attributes from the interface (now resolved). */
- if (sym->ts.interface->attr.if_source
- || sym->ts.interface->attr.intrinsic)
- {
- gfc_symbol *ifc = sym->ts.interface;
- resolve_symbol (ifc);
-
- if (ifc->attr.intrinsic)
- resolve_intrinsic (ifc, &ifc->declared_at);
-
- if (ifc->result)
- sym->ts = ifc->result->ts;
- else
- sym->ts = ifc->ts;
- sym->ts.interface = ifc;
- sym->attr.function = ifc->attr.function;
- sym->attr.subroutine = ifc->attr.subroutine;
- gfc_copy_formal_args (sym, ifc);
-
- 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.contiguous = ifc->attr.contiguous;
- sym->attr.recursive = ifc->attr.recursive;
- sym->attr.always_explicit = ifc->attr.always_explicit;
- sym->attr.ext_attr |= ifc->attr.ext_attr;
- /* Copy array spec. */
- sym->as = gfc_copy_array_spec (ifc->as);
- if (sym->as)
- {
- int i;
- for (i = 0; i < sym->as->rank; i++)
- {
- gfc_expr_replace_symbols (sym->as->lower[i], sym);
- gfc_expr_replace_symbols (sym->as->upper[i], sym);
- }
- }
- /* Copy char length. */
- if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
- {
- sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
- if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
- && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
- return;
- }
- }
- else if (sym->ts.interface->name[0] != '\0')
- {
- gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
- sym->ts.interface->name, sym->name, &sym->declared_at);
- return;
- }
- }
+ && sym->attr.if_source != IFSRC_DECL
+ && resolve_procedure_interface (sym) == FAILURE)
+ return;
if (sym->attr.is_protected && !sym->attr.proc_pointer
&& (sym->attr.procedure || sym->attr.external))
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
return;
- /* For associate names, resolve corresponding expression and make sure
- they get their type-spec set this way. */
+ /* Resolve associate names. */
if (sym->assoc)
- {
- gcc_assert (sym->attr.flavor == FL_VARIABLE);
- if (gfc_resolve_expr (sym->assoc->target) != SUCCESS)
- return;
-
- sym->ts = sym->assoc->target->ts;
- gcc_assert (sym->ts.type != BT_UNKNOWN);
- }
+ resolve_assoc_var (sym, true);
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
described in 14.7.5, to those variables that have not already
been assigned one. */
if (sym->ts.type == BT_DERIVED
- && sym->attr.referenced
&& sym->ns == gfc_current_ns
&& !sym->value
&& !sym->attr.allocatable
if ((!a->save && !a->dummy && !a->pointer
&& !a->in_common && !a->use_assoc
+ && (a->referenced || a->result)
&& !(a->function && sym != sym->result))
|| (a->dummy && a->intent == INTENT_OUT && !a->pointer))
apply_default_init (sym);
}
+ if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
+ && sym->attr.dummy && sym->attr.intent == INTENT_OUT
+ && !CLASS_DATA (sym)->attr.class_pointer
+ && !CLASS_DATA (sym)->attr.allocatable)
+ apply_default_init (sym);
+
/* If this symbol has a type-spec, check it. */
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
if (sym == NULL)
return 0;
attr = sym->attr;
- if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
+ if (attr.flavor == FL_PROCEDURE && attr.pure)
return 1;
}
return 0;
attr = sym->attr;
- return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
+ return attr.flavor == FL_PROCEDURE && attr.pure;
+}
+
+
+/* Test whether a symbol is implicitly pure or not. For a NULL pointer,
+ checks if the current namespace is implicitly pure. Note that this
+ function returns false for a PURE procedure. */
+
+int
+gfc_implicit_pure (gfc_symbol *sym)
+{
+ symbol_attribute attr;
+
+ if (sym == NULL)
+ {
+ /* Check if the current namespace is implicit_pure. */
+ sym = gfc_current_ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE
+ && attr.implicit_pure && !attr.pure)
+ return 1;
+ return 0;
+ }
+
+ attr = sym->attr;
+
+ return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
}
gfc_namespace *n;
bitmap_obstack old_obstack;
+ if (ns->resolved == 1)
+ return;
+
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);