/* 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;
+ sym->result = sym;
+ }
+ 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);
shape until we know if it has the pointer or allocatable attributes.
*/
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable))
+ && !(sym->attr.pointer || sym->attr.allocatable)
+ && sym->attr.flavor != FL_PROCEDURE)
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
&& sym->attr.flavor != FL_PROCEDURE)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN)
- gfc_error ("Argument '%s' of pure function '%s' at %L must be "
- "INTENT(IN)", sym->name, proc->name,
- &sym->declared_at);
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
+ "of pure function '%s' at %L with VALUE "
+ "attribute but without INTENT(IN)", sym->name,
+ proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure function '%s' at %L must be "
+ "INTENT(IN) or VALUE", sym->name, proc->name,
+ &sym->declared_at);
+ }
if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
- gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
- "have its INTENT specified", sym->name, proc->name,
- &sym->declared_at);
+ {
+ if (sym->attr.value)
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
+ "of pure subroutine '%s' at %L with VALUE "
+ "attribute but without INTENT", sym->name,
+ proc->name, &sym->declared_at);
+ else
+ gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
+ "have its INTENT specified or have the VALUE "
+ "attribute", sym->name, proc->name, &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))
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. */
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
- if (!cl || !cl->length)
+ if ((!cl || !cl->length) && !sym->result->ts.deferred)
{
/* See if this is a module-procedure and adapt error message
accordingly. */
/* 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;
t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
+ /* For strings, the length of the constructor should be the same as
+ the one of the structure, ensure this if the lengths are known at
+ compile time and when we are dealing with PARAMETER or structure
+ constructors. */
+ if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
+ && comp->ts.u.cl->length
+ && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
+ && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
+ comp->ts.u.cl->length->value.integer) != 0)
+ {
+ if (cons->expr->expr_type == EXPR_VARIABLE
+ && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ {
+ /* Wrap the parameter in an array constructor (EXPR_ARRAY)
+ to make use of the gfc_resolve_character_array_constructor
+ machinery. The expression is later simplified away to
+ an array of string literals. */
+ gfc_expr *para = cons->expr;
+ cons->expr = gfc_get_expr ();
+ cons->expr->ts = para->ts;
+ cons->expr->where = para->where;
+ cons->expr->expr_type = EXPR_ARRAY;
+ cons->expr->rank = para->rank;
+ cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
+ gfc_constructor_append_expr (&cons->expr->value.constructor,
+ para, &cons->expr->where);
+ }
+ if (cons->expr->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *p;
+ p = gfc_constructor_first (cons->expr->value.constructor);
+ if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
+ {
+ gfc_charlen *cl, *cl2;
+
+ cl2 = NULL;
+ for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
+ {
+ if (cl == cons->expr->ts.u.cl)
+ break;
+ cl2 = cl;
+ }
+
+ gcc_assert (cl);
+
+ if (cl2)
+ cl2->next = cl->next;
+
+ gfc_free_expr (cl->length);
+ free (cl);
+ }
+
+ cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ cons->expr->ts.u.cl->length_from_typespec = true;
+ cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
+ gfc_resolve_character_array_constructor (cons->expr);
+ }
+ }
+
if (cons->expr->expr_type == EXPR_NULL
&& !(comp->attr.pointer || comp->attr.allocatable
|| comp->attr.proc_pointer
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)
return SUCCESS;
+ /* Already resolved. */
+ if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
+ return SUCCESS;
+
/* 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->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
if (!gsym->ns->resolved)
{
gfc_dt_list *old_dt_list;
+ struct gfc_omp_saved_state old_omp_state;
/* Stash away derived types so that the backend_decls do not
get mixed up. */
old_dt_list = gfc_derived_types;
gfc_derived_types = NULL;
+ /* And stash away openmp state. */
+ gfc_omp_save_and_clear_state (&old_omp_state);
gfc_resolve (gsym->ns);
/* Restore the derived types of this namespace. */
gfc_derived_types = old_dt_list;
+ /* And openmp state. */
+ gfc_omp_restore_state (&old_omp_state);
}
/* Make sure that translation for the gsymbol occurs before
/* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
- && def_sym->ts.u.cl->length != NULL)
+ && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
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
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
+ gfc_ref *ref;
+ bool seen_section;
+
/* Make sure we have either the target or pointer attribute. */
if (!arg_attr.target && !arg_attr.pointer)
{
retval = FAILURE;
}
+ if (gfc_is_coindexed (args->expr))
+ {
+ gfc_error_now ("Coindexed argument not permitted"
+ " in '%s' call at %L", name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+
+ /* Follow references to make sure there are no array
+ sections. */
+ seen_section = false;
+
+ for (ref=args->expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ {
+ if (ref->u.ar.type == AR_SECTION)
+ seen_section = true;
+
+ if (ref->u.ar.type != AR_ELEMENT)
+ {
+ gfc_ref *r;
+ for (r = ref->next; r; r=r->next)
+ if (r->type == REF_COMPONENT)
+ {
+ gfc_error_now ("Array section not permitted"
+ " in '%s' call at %L", name,
+ &(args->expr->where));
+ retval = FAILURE;
+ break;
+ }
+ }
+ }
+ }
+
+ if (seen_section && retval == SUCCESS)
+ gfc_warning ("Array section in '%s' call at %L", name,
+ &(args->expr->where));
+
/* See if we have interoperable type and type param. */
if (verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
/* 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)
&& sym->ts.u.cl
&& sym->ts.u.cl->length == NULL
&& !sym->attr.dummy
+ && !sym->ts.deferred
&& expr->value.function.esym == NULL
&& !sym->attr.contained)
{
}
}
+ 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;
switch (ar->dimen_type[i])
{
case DIMEN_VECTOR:
+ case DIMEN_THIS_IMAGE:
break;
case DIMEN_STAR:
if (ar->codimen != 0)
for (i = as->rank; i < as->rank + as->corank; i++)
{
- if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
+ && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
{
gfc_error ("Coindex of codimension %d must be a scalar at %L",
i + 1 - as->rank, &ar->where);
return FAILURE;
}
+ if (as->corank && ar->codimen == 0)
+ {
+ int n;
+ ar->codimen = as->corank;
+ for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+ ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+ }
+
return SUCCESS;
}
&ar->c_where[i], e->rank);
return FAILURE;
}
+
+ /* Fill in the upper bound, which may be lower than the
+ specified one for something like a(2:10:5), which is
+ identical to a(2:7:5). Only relevant for strides not equal
+ to one. */
+ if (ar->dimen_type[i] == DIMEN_RANGE
+ && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0)
+ {
+ mpz_t size, end;
+
+ if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS)
+ {
+ if (ar->end[i] == NULL)
+ {
+ ar->end[i] =
+ gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &ar->where);
+ mpz_set (ar->end[i]->value.integer, end);
+ }
+ else if (ar->end[i]->ts.type == BT_INTEGER
+ && ar->end[i]->expr_type == EXPR_CONSTANT)
+ {
+ mpz_set (ar->end[i]->value.integer, end);
+ }
+ else
+ gcc_unreachable ();
+
+ mpz_clear (size);
+ mpz_clear (end);
+ }
+ }
}
if (ar->type == AR_FULL && ar->as->rank == 0)
for (ref = e->ref; ref; ref = ref->next)
{
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->attr.function && !ref->next)
+ rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
+
if (ref->type != REF_ARRAY)
continue;
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)
{
for (n = 0; n < e->rank; n++)
mpz_clear (e->shape[n]);
- gfc_free (e->shape);
+ free (e->shape);
}
/* Give the expression the right symtree! */
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;
}
/* Make sure that we have the right specific instance for the name. */
derived = get_declared_from_expr (NULL, NULL, e);
- st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
+ st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
e->value.compcall.tbp = st->n.tb;
/* 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
/* Deal with typebound operators for CLASS objects. */
expr = code->expr1->value.compcall.base_object;
- if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
- && code->expr1->value.compcall.name)
+ if (expr && expr->ts.type == BT_CLASS && code->expr1->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;
- declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ declared = expr->ts.u.derived;
+ 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 : 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");
+ code->expr1->ref = gfc_copy_ref (expr->ref);
+ 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, 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)
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
{
- gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
+ gfc_error ("Coindexed allocatable object at %L", &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, true, _("DEALLOCATE object"))
+ == FAILURE)
+ return FAILURE;
+ if (gfc_check_vardef_context (e, false, true, _("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;
+ bool coindexed;
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. */
codimension = sym->attr.codimension;
}
+ coindexed = false;
+
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
+ if (ref->u.ar.codimen > 0)
+ {
+ int n;
+ for (n = ref->u.ar.dimen;
+ n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+ {
+ coindexed = true;
+ break;
+ }
+ }
+
if (ref->next != NULL)
pointer = 0;
break;
case REF_COMPONENT:
/* F2008, C644. */
- if (gfc_is_coindexed (e))
+ if (coindexed)
{
gfc_error ("Coindexed allocatable object at %L",
&e->where);
&e->where, &code->expr3->where);
goto failure;
}
+
+ /* Check F2008, C642. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)))
+ {
+ gfc_error ("The source-expr at %L shall neither be of type "
+ "LOCK_TYPE nor have a LOCK_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
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, true, _("ALLOCATE object"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e2, false, true, _("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)
+ {
+ /* Make sure the vtab symbol is present when
+ the module variables are generated. */
+ gfc_typespec ts = e->ts;
+ if (code->expr3)
+ ts = code->expr3->ts;
+ else if (code->ext.alloc.ts.type == BT_DERIVED)
+ ts = code->ext.alloc.ts;
+ gfc_find_derived_vtab (ts.u.derived);
+ }
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 "
ar = &ref2->u.ar;
- if (codimension && ar->codimen == 0)
- {
- gfc_error ("Coarray specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
- }
+ if (codimension)
+ for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
+ if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
for (i = 0; i < ar->dimen; i++)
{
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
case DIMEN_STAR:
+ case DIMEN_THIS_IMAGE:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
goto 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, 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, 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, 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
return;
}
+ /* F08:C935. */
+ if (ts->u.derived->attr.proc_pointer_comp)
+ {
+ gfc_error ("Data transfer element at %L cannot have "
+ "procedure pointer components", &code->loc);
+ return;
+ }
+
if (ts->u.derived->attr.alloc_comp)
{
gfc_error ("Data transfer element at %L cannot have "
static void
+resolve_lock_unlock (gfc_code *code)
+{
+ if (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || !(gfc_expr_attr (code->expr1).codimension
+ || gfc_is_coindexed (code->expr1)))
+ gfc_error ("Lock variable at %L must be a scalar coarray of type "
+ "LOCK_TYPE", &code->expr1->where);
+
+ /* Check STAT. */
+ if (code->expr2
+ && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+ || code->expr2->expr_type != EXPR_VARIABLE))
+ gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+ &code->expr2->where);
+
+ if (code->expr2
+ && gfc_check_vardef_context (code->expr2, false, false,
+ _("STAT variable")) == FAILURE)
+ return;
+
+ /* Check ERRMSG. */
+ if (code->expr3
+ && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+ || code->expr3->expr_type != EXPR_VARIABLE))
+ gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+ &code->expr3->where);
+
+ if (code->expr3
+ && gfc_check_vardef_context (code->expr3, false, false,
+ _("ERRMSG variable")) == FAILURE)
+ return;
+
+ /* Check ACQUIRED_LOCK. */
+ if (code->expr4
+ && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
+ || code->expr4->expr_type != EXPR_VARIABLE))
+ gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
+ "variable", &code->expr4->where);
+
+ if (code->expr4
+ && gfc_check_vardef_context (code->expr4, false, false,
+ _("ACQUIRED_LOCK variable")) == FAILURE)
+ return;
+}
+
+
+static void
resolve_sync (gfc_code *code)
{
/* Check imageset. The * case matches expr1 == NULL. */
total_var = gfc_count_forall_iterators (code);
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
- var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
+ var_expr = XCNEWVEC (gfc_expr *, total_var);
}
/* The information about FORALL iterator, including FORALL index start, end
gcc_assert (forall_save == 0);
/* VAR_EXPR is not needed any more. */
- gfc_free (var_expr);
+ free (var_expr);
total_var = 0;
}
}
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;
resolve_sync (code);
break;
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ resolve_lock_unlock (code);
+ break;
+
case EXEC_ENTRY:
/* Keep track of which entry we are up to. */
current_entry_id = code->ext.entry->id;
if (t == FAILURE)
break;
+ if (gfc_check_vardef_context (code->expr1, false, 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, false,
+ _("pointer assignment"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e, false, 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
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
+ /* Avoid double diagnostics for function result symbols. */
+ if ((sym->result || sym->attr.result) && !sym->attr.dummy
+ && (sym->ns != gfc_current_ns))
+ return SUCCESS;
+
/* Constraints on deferred shape variable. */
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
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->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;
/* Also, they must not have the SAVE attribute.
SAVE_IMPLICIT is checked below. */
- if (sym->attr.save == SAVE_EXPLICIT)
+ if (sym->as && sym->attr.codimension)
+ {
+ int corank = sym->as->corank;
+ sym->as->corank = 0;
+ no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
+ sym->as->corank = corank;
+ }
+ if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
/* Reject illegal initializers. */
if (!sym->mark && sym->value)
{
- if (sym->attr.allocatable)
+ if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.allocatable))
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.external)
the host. */
if (!(sym->ns->parent
&& sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ && gfc_check_symbol_access (sym))
{
gfc_interface *iface;
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a "
"PRIVATE type and cannot be a dummy argument"
" of '%s', which is PUBLIC at %L",
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.u.derived->attr.use_assoc
- && !gfc_check_access (arg->sym->ts.u.derived->attr.access,
- arg->sym->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (arg->sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure "
"'%s' in PUBLIC interface '%s' at %L "
"takes dummy arguments of '%s' which is "
return FAILURE;
}
+ if (sym->attr.proc == PROC_ST_FUNCTION
+ && (sym->attr.allocatable || sym->attr.pointer))
+ {
+ gfc_error ("Statement function '%s' at %L may not have pointer or "
+ "allocatable attribute", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
char-len-param shall not be array-valued, pointer-valued, recursive
or pure. ....snip... A character value of * may only be used in the
}
/* Appendix B.2 of the standard. Contained functions give an
- error anyway. Fixed-form is likely to be F77/legacy. */
- if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
+ error anyway. Fixed-form is likely to be F77/legacy. Deferred
+ character length is an F2003 feature. */
+ if (!sym->attr.contained
+ && gfc_current_form != FORM_FIXED
+ && !sym->ts.deferred)
gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"CHARACTER(*) function '%s' at %L",
sym->name, &sym->declared_at);
target_name = target->specific_st->name;
/* Defined for this type directly. */
- if (target->specific_st->n.tb)
+ if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
{
target->specific = target->specific_st->n.tb;
goto specific_found;
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;
return FAILURE;
}
- if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
+ && !c->ts.deferred)
{
if (c->ts.u.cl->length == NULL
|| (resolve_charlen (c->ts.u.cl) == FAILURE)
}
}
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred
+ && !c->attr.pointer && !c->attr.allocatable)
+ {
+ gfc_error ("Character component '%s' of '%s' at %L with deferred "
+ "length must be a POINTER or ALLOCATABLE",
+ c->name, sym->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
- && gfc_check_access (sym->attr.access, sym->ns->default_access)
+ && gfc_check_symbol_access (sym)
&& !is_sym_host_assoc (c->ts.u.derived, sym->ns)
&& !c->ts.u.derived->attr.use_assoc
- && !gfc_check_access (c->ts.u.derived->attr.access,
- c->ts.u.derived->ns->default_access)
+ && !gfc_check_symbol_access (c->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' "
"is a PRIVATE type and cannot be a component of "
"'%s', which is PUBLIC at %L", c->name,
sym->name, &sym->declared_at) == 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 "
return FAILURE;
}
- if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
+ if (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.class_pointer
&& CLASS_DATA (c)->ts.u.derived->components == NULL
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
{
}
/* C437. */
- if (c->ts.type == BT_CLASS
- && !(CLASS_DATA (c)->attr.class_pointer
- || CLASS_DATA (c)->attr.allocatable))
+ if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
+ && (!c->attr.class_ok
+ || !(CLASS_DATA (c)->attr.class_pointer
+ || CLASS_DATA (c)->attr.allocatable)))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
gfc_namelist *nl;
gfc_symbol *nlsym;
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ /* Check again, the check in match only works if NAMELIST comes
+ after the decl. */
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
+ {
+ gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
+ "allowed", nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with assumed shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ if (is_non_constant_shape_array (nl->sym)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with nonconstant shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ if (nl->sym->ts.type == BT_CHARACTER
+ && (nl->sym->ts.u.cl->length == NULL
+ || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' with nonconstant character length in "
+ "namelist '%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ if (nl->sym->ts.type == BT_CLASS)
+ {
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
+ "polymorphic and requires a defined input/output "
+ "procedure", nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (nl->sym->ts.type == BT_DERIVED
+ && (nl->sym->ts.u.derived->attr.alloc_comp
+ || nl->sym->ts.u.derived->attr.pointer_comp))
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' in namelist '%s' at %L with ALLOCATABLE "
+ "or POINTER components", nl->sym->name,
+ sym->name, &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
+ "ALLOCATABLE or POINTER components and thus requires "
+ "a defined input/output procedure", 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))
+ if (gfc_check_symbol_access (sym))
{
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
&& !is_sym_host_assoc (nl->sym, sym->ns)
- && !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
+ && !gfc_check_symbol_access (nl->sym))
{
gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
"cannot be member of PUBLIC namelist '%s' at %L",
/* Types with private components that are defined in the same module. */
if (nl->sym->ts.type == BT_DERIVED
&& !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
- && !gfc_check_access (nl->sym->ts.u.derived->attr.private_comp
- ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
- nl->sym->ns->default_access))
+ && nl->sym->ts.u.derived->attr.private_comp)
{
gfc_error ("NAMELIST object '%s' has PRIVATE components and "
"cannot be a member of PUBLIC namelist '%s' at %L",
}
}
- 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_namespace *ns;
gfc_component *c;
- /* Avoid double resolution of function result symbols. */
- if ((sym->result || sym->attr.result) && (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)
}
/* Assumed size arrays and assumed shape arrays must be dummy
- arguments. */
+ arguments. Array-spec's of implied-shape should have been resolved to
+ AS_EXPLICIT already. */
- if (sym->as != NULL
- && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
- || sym->as->type == AS_ASSUMED_SHAPE)
- && sym->attr.dummy == 0)
+ if (sym->as)
{
- if (sym->as->type == AS_ASSUMED_SIZE)
- gfc_error ("Assumed size array at %L must be a dummy argument",
- &sym->declared_at);
- else
- gfc_error ("Assumed shape array at %L must be a dummy argument",
- &sym->declared_at);
- return;
+ gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
+ if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
+ || sym->as->type == AS_ASSUMED_SHAPE)
+ && sym->attr.dummy == 0)
+ {
+ if (sym->as->type == AS_ASSUMED_SIZE)
+ gfc_error ("Assumed size array at %L must be a dummy argument",
+ &sym->declared_at);
+ else
+ gfc_error ("Assumed shape array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
return;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
- if (!ds && sym->attr.function
- && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
{
symtree = gfc_new_symtree (&sym->ns->sym_root,
sym->ts.u.derived->name);
if (sym->ts.type == BT_DERIVED
&& sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ts.u.derived->attr.use_assoc
- && gfc_check_access (sym->attr.access, sym->ns->default_access)
- && !gfc_check_access (sym->ts.u.derived->attr.access,
- sym->ts.u.derived->ns->default_access)
+ && gfc_check_symbol_access (sym)
+ && !gfc_check_symbol_access (sym->ts.u.derived)
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L "
"of PRIVATE derived type '%s'",
(sym->attr.flavor == FL_PARAMETER) ? "parameter"
sym->ts.u.derived->name) == FAILURE)
return;
+ /* F2008, C1302. */
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
+ && !sym->attr.codimension)
+ {
+ gfc_error ("Variable '%s' at %L of type LOCK_TYPE must be a coarray",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
}
}
+ /* F2008, C542. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
+ gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+
/* F2008, C526. */
if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| sym->attr.codimension)
if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| sym->attr.codimension)
&& !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+ || sym->ns->save_all
|| sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program
|| sym->attr.function || sym->attr.result || sym->attr.use_assoc))
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))
has_pointer = sym->attr.pointer;
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
+ where);
+ return FAILURE;
+ }
+
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
- if (ref->type == REF_ARRAY && ref->u.ar.codimen)
- {
- gfc_error ("DATA element '%s' at %L cannot have a coindex",
- sym->name, where);
- return FAILURE;
- }
-
if (has_pointer
&& ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL)
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;
}
e->ts.u.cl = NULL;
}
ref = ref->next;
- gfc_free (mem);
+ free (mem);
}
/* Any further ref is an error. */
if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
&& !sym->attr.contained
- && !gfc_check_access (sym->ts.u.derived->attr.access,
- sym->ts.u.derived->ns->default_access)
- && gfc_check_access (sym->attr.access, sym->ns->default_access))
+ && !gfc_check_symbol_access (sym->ts.u.derived)
+ && gfc_check_symbol_access (sym))
{
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at "
"%L of PRIVATE type '%s'", sym->name,
resolve_contained_functions (ns);
+ if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
+ && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ resolve_formal_arglist (ns->proc_name);
+
gfc_traverse_ns (ns, resolve_bind_c_derived_types);
for (cl = ns->cl_list; cl; cl = cl->next)
gfc_namespace *n;
bitmap_obstack old_obstack;
+ if (ns->resolved == 1)
+ return;
+
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);
OSDN Git Service
