/* 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;
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);
+ gfc_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->ts.type == BT_CLASS
- && (comp->ts.u.derived->components->attr.pointer
- || comp->ts.u.derived->components->attr.allocatable))))
+ && (CLASS_DATA (comp)->attr.class_pointer
+ || CLASS_DATA (comp)->attr.allocatable))))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
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
gfc_global_used (gsym, where);
if (gfc_option.flag_whole_file
- && sym->attr.if_source == IFSRC_UNKNOWN
+ && (sym->attr.if_source == IFSRC_UNKNOWN
+ || sym->attr.if_source == IFSRC_IFBODY)
&& gsym->type != GSYM_UNKNOWN
&& gsym->ns
&& gsym->ns->resolved != -1
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
+ gfc_symbol *def_sym;
+
/* Resolve the gsymbol namespace if needed. */
if (!gsym->ns->resolved)
{
}
}
- if (gsym->ns->proc_name->attr.function
- && gsym->ns->proc_name->as
- && gsym->ns->proc_name->as->rank
- && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
- gfc_error ("The reference to function '%s' at %L either needs an "
- "explicit INTERFACE or the rank is incorrect", sym->name,
- where);
-
- /* Non-assumed length character functions. */
- if (sym->attr.function && sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ def_sym = gsym->ns->proc_name;
+ if (def_sym->attr.entry_master)
{
- gfc_charlen *cl = sym->ts.u.cl;
-
- if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Nonconstant character-length function '%s' at %L "
- "must have an explicit interface", sym->name,
- &sym->declared_at);
- }
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
}
/* Differences in constant character lengths. */
{
long int l1 = 0, l2 = 0;
gfc_charlen *cl1 = sym->ts.u.cl;
- gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
+ gfc_charlen *cl2 = def_sym->ts.u.cl;
if (cl1 != NULL
&& cl1->length != NULL
/* Type mismatch of function return type and expected type. */
if (sym->attr.function
- && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
+ && !gfc_compare_types (&sym->ts, &def_sym->ts))
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
- gfc_typename (&gsym->ns->proc_name->ts));
+ gfc_typename (&def_sym->ts));
- /* Assumed shape arrays as dummy arguments. */
- if (gsym->ns->proc_name->formal)
+ if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
{
- gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
+ gfc_formal_arglist *arg = def_sym->formal;
for ( ; arg; arg = arg->next)
- if (arg->sym && arg->sym->as
- && arg->sym->as->type == AS_ASSUMED_SHAPE)
+ if (!arg->sym)
+ continue;
+ /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
+ else if (arg->sym->attr.allocatable
+ || arg->sym->attr.asynchronous
+ || arg->sym->attr.optional
+ || arg->sym->attr.pointer
+ || arg->sym->attr.target
+ || arg->sym->attr.value
+ || arg->sym->attr.volatile_)
+ {
+ gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
+ "has an attribute that requires an explicit "
+ "interface for this procedure", arg->sym->name,
+ sym->name, &sym->declared_at);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
- "'%s' argument must have an explicit interface",
+ "argument '%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
- else if (arg->sym && arg->sym->attr.optional)
+ /* F2008, 12.4.2.2 (2c) */
+ else if (arg->sym->attr.codimension)
{
- gfc_error ("Procedure '%s' at %L with optional dummy argument "
+ gfc_error ("Procedure '%s' at %L with coarray dummy argument "
"'%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
+ else if (false) /* TODO: is a parametrized derived type */
+ {
+ gfc_error ("Procedure '%s' at %L with parametrized derived "
+ "type argument '%s' must have an explicit "
+ "interface", sym->name, &sym->declared_at,
+ arg->sym->name);
+ break;
+ }
+ /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
+ else if (arg->sym->ts.type == BT_CLASS)
+ {
+ gfc_error ("Procedure '%s' at %L with polymorphic dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
+ }
+
+ if (def_sym->attr.function)
+ {
+ /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
+ if (def_sym->as && def_sym->as->rank
+ && (!sym->as || sym->as->rank != def_sym->as->rank))
+ gfc_error ("The reference to function '%s' at %L either needs an "
+ "explicit INTERFACE or the rank is incorrect", sym->name,
+ where);
+
+ /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
+ if ((def_sym->result->attr.pointer
+ || def_sym->result->attr.allocatable)
+ && (sym->attr.if_source != IFSRC_IFBODY
+ || def_sym->result->attr.pointer
+ != sym->result->attr.pointer
+ || def_sym->result->attr.allocatable
+ != sym->result->attr.allocatable))
+ gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
+ "result must have an explicit interface", sym->name,
+ where);
+
+ /* 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)
+ {
+ gfc_charlen *cl = sym->ts.u.cl;
+
+ if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Nonconstant character-length function '%s' at %L "
+ "must have an explicit interface", sym->name,
+ &sym->declared_at);
+ }
+ }
+ }
+
+ /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
+ if (def_sym->attr.elemental && !sym->attr.elemental)
+ {
+ gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
+ "interface", sym->name, &sym->declared_at);
+ }
+
+ /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
+ if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
+ {
+ gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
+ "an explicit interface", sym->name, &sym->declared_at);
}
if (gfc_option.flag_whole_file == 1
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
- gfc_procedure_use (gsym->ns->proc_name, actual, where);
+ if (sym->attr.if_source != IFSRC_IFBODY)
+ gfc_procedure_use (def_sym, actual, where);
gfc_errors_to_warnings (0);
}
&& !(sym->attr.intrinsic
|| gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
&& sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer
&& !sym->attr.use_assoc
&& sym->name)
return true;
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
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
- int optional_arg = 0, is_pointer = 0;
+ int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
gfc_typespec *arg_ts;
+ symbol_attribute arg_attr;
if (args->expr->expr_type == EXPR_CONSTANT
|| args->expr->expr_type == EXPR_OP
and not necessarily that of the expr symbol (args_sym), because
the actual expression could be a part-ref of the expr symbol. */
arg_ts = &(args->expr->ts);
-
- is_pointer = gfc_is_data_pointer (args->expr);
+ arg_attr = gfc_expr_attr (args->expr);
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
else if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
/* Make sure we have either the target or pointer attribute. */
- if (!args_sym->attr.target && !is_pointer)
+ if (!arg_attr.target && !arg_attr.pointer)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
}
}
}
- else if (is_pointer
+ else if (arg_attr.pointer
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
&(args->expr->where));
retval = FAILURE;
}
+ else if (arg_ts->type == BT_CLASS)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
+ "polymorphic", args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
}
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
/* 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;
e->rank = op1->rank;
if (e->shape == NULL)
{
- t = compare_shapes(op1, op2);
+ t = compare_shapes (op1, op2);
if (t == FAILURE)
e->shape = NULL;
else
- e->shape = gfc_copy_shape (op1->shape, op1->rank);
+ e->shape = gfc_copy_shape (op1->shape, op1->rank);
}
}
else
gfc_ref *ref;
if (e->symtree->n.sym->ts.type == BT_CLASS)
- as = e->symtree->n.sym->ts.u.derived->components->as;
+ as = CLASS_DATA (e->symtree->n.sym)->as;
else
as = e->symtree->n.sym->as;
derived = NULL;
&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)
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
sym->entry_id = current_entry_id + 1;
}
+ /* If a symbol has been host_associated mark it. This is used latter,
+ to identify if aliasing is possible via host association. */
+ if (sym->attr.flavor == FL_VARIABLE
+ && gfc_current_ns->parent
+ && (gfc_current_ns->parent == sym->ns
+ || (gfc_current_ns->parent->parent
+ && gfc_current_ns->parent->parent == sym->ns)))
+ sym->attr.host_assoc = 1;
+
resolve_procedure:
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
t = FAILURE;
{
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;
}
}
+/* Get the ultimate declared type from an expression. In addition,
+ return the last class/derived type reference and the copy of the
+ reference list. */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+ gfc_expr *e)
+{
+ gfc_symbol *declared;
+ gfc_ref *ref;
+
+ declared = NULL;
+ if (class_ref)
+ *class_ref = NULL;
+ if (new_ref)
+ *new_ref = gfc_copy_ref (e->ref);
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type != REF_COMPONENT)
+ continue;
+
+ if (ref->u.c.component->ts.type == BT_CLASS
+ || ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ declared = ref->u.c.component->ts.u.derived;
+ if (class_ref)
+ *class_ref = ref;
+ }
+ }
+
+ if (declared == NULL)
+ declared = e->symtree->n.sym->ts.u.derived;
+
+ return declared;
+}
+
+
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
which of the specific bindings (if any) matches the arglist and transform
the expression into a call of that binding. */
{
gfc_typebound_proc* genproc;
const char* genname;
+ gfc_symtree *st;
+ gfc_symbol *derived;
gcc_assert (e->expr_type == EXPR_COMPCALL);
genname = e->value.compcall.name;
if (matches)
{
e->value.compcall.tbp = g->specific;
+ genname = g->specific_st->name;
/* Pass along the name for CLASS methods, where the vtab
procedure pointer component has to be referenced. */
if (name)
- *name = g->specific_st->name;
+ *name = genname;
goto success;
}
}
return FAILURE;
success:
+ /* 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);
+ if (st)
+ e->value.compcall.tbp = st->n.tb;
+
return SUCCESS;
}
}
-/* Get the ultimate declared type from an expression. In addition,
- return the last class/derived type reference and the copy of the
- reference list. */
-static gfc_symbol*
-get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
- gfc_expr *e)
-{
- gfc_symbol *declared;
- gfc_ref *ref;
-
- declared = NULL;
- *class_ref = NULL;
- *new_ref = gfc_copy_ref (e->ref);
- for (ref = *new_ref; ref; ref = ref->next)
- {
- if (ref->type != REF_COMPONENT)
- continue;
-
- if (ref->u.c.component->ts.type == BT_CLASS
- || ref->u.c.component->ts.type == BT_DERIVED)
- {
- declared = ref->u.c.component->ts.u.derived;
- *class_ref = ref;
- }
- }
-
- if (declared == NULL)
- declared = e->symtree->n.sym->ts.u.derived;
-
- return declared;
-}
-
/* Resolve a typebound function, or 'method'. First separate all
the non-CLASS references by calling resolve_compcall directly. */
gfc_ref *class_ref;
gfc_symtree *st;
const char *name;
- const char *genname;
gfc_typespec ts;
+ gfc_expr *expr;
st = e->symtree;
+
+ /* Deal with typebound operators for CLASS objects. */
+ expr = e->value.compcall.base_object;
+ 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->ts;
+ declared = 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);
+
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
+
+ /* Use the generic name if it is there. */
+ name = name ? name : e->value.function.esym->name;
+ e->symtree = expr->symtree;
+ 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;
+ }
+
if (st == NULL)
return resolve_compcall (e, NULL);
+ if (resolve_ref (e) == FAILURE)
+ return FAILURE;
+
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
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;
- /* Keep the generic name so that the vtab reference can be made. */
- genname = NULL;
- if (e->value.compcall.tbp->is_generic)
- genname = e->value.compcall.name;
-
/* Treat the call as if it is a typebound procedure, in order to roll
out the correct name for the specific function. */
- resolve_compcall (e, &name);
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
ts = e->ts;
/* Then convert the expression to a procedure pointer component call. */
e->value.function.esym = NULL;
e->symtree = st;
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- e->ref = new_ref;
- }
+ if (new_ref)
+ e->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (e, "$vptr");
- if (genname)
- {
- /* A generic procedure needs the subsidiary vtabs and vtypes for
- the specific procedures to have been build. */
- gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (declared, true);
- gcc_assert (vtab);
- gfc_add_component_ref (e, genname);
- }
+ /* '_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
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
- const char *genname;
const char *name;
gfc_typespec ts;
+ gfc_expr *expr;
st = code->expr1->symtree;
+
+ /* 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)
+ {
+ /* 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);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (declared);
+
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
+
+ /* 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_vptr_component (code->expr1);
+ gfc_add_component_ref (code->expr1, name);
+ code->expr1->value.function.esym = NULL;
+ return SUCCESS;
+ }
+
if (st == NULL)
return resolve_typebound_call (code, NULL);
+ if (resolve_ref (code->expr1) == FAILURE)
+ return FAILURE;
+
/* Get the CLASS declared type. */
- declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+ get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
gfc_free_ref_list (new_ref);
return resolve_typebound_call (code, NULL);
- }
-
- c = gfc_find_component (declared, "$data", true, true);
- declared = c->ts.u.derived;
-
- /* Keep the generic name so that the vtab reference can be made. */
- genname = NULL;
- if (code->expr1->value.compcall.tbp->is_generic)
- genname = code->expr1->value.compcall.name;
+ }
- resolve_typebound_call (code, &name);
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
ts = code->expr1->ts;
/* Then convert the expression to a procedure pointer component call. */
code->expr1->value.function.esym = NULL;
code->expr1->symtree = st;
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- code->expr1->ref = new_ref;
- }
+ 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");
- if (genname)
- {
- /* A generic procedure needs the subsidiary vtabs and vtypes for
- the specific procedures to have been build. */
- gfc_symbol *vtab;
- vtab = gfc_find_derived_vtab (declared, true);
- gcc_assert (vtab);
- gfc_add_component_ref (code->expr1, genname);
- }
+ /* '_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
{
expression_rank (e);
if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
- gfc_expand_constructor (e);
+ gfc_expand_constructor (e, false);
}
/* This provides the opportunity for the length of constructors with
{
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
here rather then add a duplicate test for it above. */
- gfc_expand_constructor (e);
+ gfc_expand_constructor (e, false);
t = gfc_resolve_character_array_constructor (e);
}
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;
if (sym->ts.type == BT_CLASS)
{
- allocatable = sym->ts.u.derived->components->attr.allocatable;
- pointer = sym->ts.u.derived->components->attr.pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
}
else
{
}
for (ref = e->ref; ref; ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
c = ref->u.c.component;
if (c->ts.type == BT_CLASS)
{
- allocatable = c->ts.u.derived->components->attr.allocatable;
- pointer = c->ts.u.derived->components->attr.pointer;
+ allocatable = CLASS_DATA (c)->attr.allocatable;
+ pointer = CLASS_DATA (c)->attr.class_pointer;
}
else
{
bad:
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
- }
-
- 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
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
{
+ gfc_ref *tail;
+ for (tail = e2->ref; tail && tail->next; tail = tail->next);
+
/* First compare rank. */
- if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ if (tail && e1->rank != tail->u.ar.as->rank)
{
gfc_error ("Source-expr at %L must be scalar or have the "
"same rank as the allocate-object at %L",
for (i = 0; i < e1->rank; i++)
{
- if (e2->ref->u.ar.end[i])
+ if (tail->u.ar.end[i])
{
- mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
- mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_set (s, tail->u.ar.end[i]->value.integer);
+ mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
mpz_add_ui (s, s, 1);
}
else
{
- mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_set (s, tail->u.ar.start[i]->value.integer);
}
if (mpz_cmp (e1->shape[i], s) != 0)
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;
+ gfc_symbol *sym = NULL;
gfc_alloc *a;
gfc_component *c;
- gfc_expr *init_e;
-
- /* 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. */
{
if (sym->ts.type == BT_CLASS)
{
- allocatable = sym->ts.u.derived->components->attr.allocatable;
- pointer = sym->ts.u.derived->components->attr.pointer;
- dimension = sym->ts.u.derived->components->attr.dimension;
- codimension = sym->ts.u.derived->components->attr.codimension;
- is_abstract = sym->ts.u.derived->components->attr.abstract;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
+ dimension = CLASS_DATA (sym)->attr.dimension;
+ codimension = CLASS_DATA (sym)->attr.codimension;
+ is_abstract = CLASS_DATA (sym)->attr.abstract;
}
else
{
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
c = ref->u.c.component;
if (c->ts.type == BT_CLASS)
{
- allocatable = c->ts.u.derived->components->attr.allocatable;
- pointer = c->ts.u.derived->components->attr.pointer;
- dimension = c->ts.u.derived->components->attr.dimension;
- codimension = c->ts.u.derived->components->attr.codimension;
- is_abstract = c->ts.u.derived->components->attr.abstract;
+ allocatable = CLASS_DATA (c)->attr.allocatable;
+ pointer = CLASS_DATA (c)->attr.class_pointer;
+ dimension = CLASS_DATA (c)->attr.dimension;
+ codimension = CLASS_DATA (c)->attr.codimension;
+ is_abstract = CLASS_DATA (c)->attr.abstract;
}
else
{
goto failure;
}
}
- else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
+
+ /* Check F08:C629. */
+ if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
+ && !code->expr3)
{
gcc_assert (e->ts.type == BT_CLASS);
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
- "type-spec or SOURCE=", sym->name, &e->where);
+ "type-spec or source-expr", sym->name, &e->where);
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;
- }
-
+ /* 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. */
- if (e->ts.type == BT_DERIVED
- && (init_e = gfc_default_initializer (&e->ts)))
- {
- gfc_code *init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr1 = gfc_expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
- }
- else if (e->ts.type == BT_CLASS
- && ((code->ext.alloc.ts.type == BT_UNKNOWN
- && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts)))
- || (code->ext.alloc.ts.type == BT_DERIVED
- && (init_e = gfc_default_initializer (&code->ext.alloc.ts)))))
+ /* 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
+ ts = e->ts;
+
+ if (ts.type == BT_CLASS)
+ ts = ts.u.derived->components->ts;
+
+ 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 "
}
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
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
- gfc_error ("Stat-variable at %L shall not be %sd within "
- "the same %s statement", &stat->where, fcn, fcn);
+ {
+ gfc_ref *ref1, *ref2;
+ bool found = true;
+
+ for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
+ ref1 = ref1->next, ref2 = ref2->next)
+ {
+ if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+ continue;
+ if (ref1->u.c.component->name != ref2->u.c.component->name)
+ {
+ found = false;
+ break;
+ }
+ }
+
+ if (found)
+ {
+ gfc_error ("Stat-variable at %L shall not be %sd within "
+ "the same %s statement", &stat->where, fcn, fcn);
+ break;
+ }
+ }
}
/* Check the errmsg variable. */
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)
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
- gfc_error ("Errmsg-variable at %L shall not be %sd within "
- "the same %s statement", &errmsg->where, fcn, fcn);
+ {
+ gfc_ref *ref1, *ref2;
+ bool found = true;
+
+ for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
+ ref1 = ref1->next, ref2 = ref2->next)
+ {
+ if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+ continue;
+ if (ref1->u.c.component->name != ref2->u.c.component->name)
+ {
+ found = false;
+ break;
+ }
+ }
+
+ if (found)
+ {
+ gfc_error ("Errmsg-variable at %L shall not be %sd within "
+ "the same %s statement", &errmsg->where, fcn, fcn);
+ break;
+ }
+ }
}
/* Check that an allocate-object appears only once in the statement.
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;
}
-/* Check if a derived type is extensible. */
+/* Check if a derived type is extensible. */
+
+bool
+gfc_type_is_extensible (gfc_symbol *sym)
+{
+ return !(sym->attr.is_bind_c || sym->attr.sequence);
+}
+
+
+/* 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;
-bool
-gfc_type_is_extensible (gfc_symbol *sym)
-{
- return !(sym->attr.is_bind_c || sym->attr.sequence);
+ /* 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;
gfc_namespace *ns;
int error = 0;
- ns = code->ext.ns;
+ ns = code->ext.block.ns;
gfc_resolve (ns);
/* Check for F03:C813. */
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = code->expr2->ts;
- selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
}
else
- selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+ selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
/* 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->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, true);
+ 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)
{
- /* Eventually, we may want to do some checks here or handle special stuff.
- But so far the only thing we can do is resolving the local namespace. */
+ /* Resolve the BLOCK's namespace. */
+ gfc_resolve (code->ext.block.ns);
- gfc_resolve (code->ext.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.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.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
{
case BT_INTEGER:
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
- mpz_init_set_si (init_expr->value.integer,
+ mpz_set_si (init_expr->value.integer,
gfc_option.flag_init_integer_value);
else
{
break;
case BT_REAL:
- mpfr_init (init_expr->value.real);
switch (gfc_option.flag_init_real)
{
case GFC_INIT_REAL_SNAN:
break;
case BT_COMPLEX:
- mpc_init2 (init_expr->value.complex, mpfr_get_default_prec());
switch (gfc_option.flag_init_real)
{
case GFC_INIT_REAL_SNAN:
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);
if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
{
/* F03:C502. */
- if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
+ if (sym->attr.class_ok
+ && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
- sym->ts.u.derived->components->ts.u.derived->name,
- sym->name, &sym->declared_at);
+ CLASS_DATA (sym)->ts.u.derived->name, sym->name,
+ &sym->declared_at);
return FAILURE;
}
/* 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;
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;
goto error;
}
- if (me_arg->ts.u.derived->components->ts.u.derived
+ if (CLASS_DATA (me_arg)->ts.u.derived
!= resolve_bindings_derived)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (me_arg->ts.u.derived->components->as
- && me_arg->ts.u.derived->components->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
goto error;
}
- if (me_arg->ts.u.derived->components->attr.allocatable)
+ if (CLASS_DATA (me_arg)->attr.allocatable)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
" be ALLOCATABLE", proc->name, &where);
goto error;
}
- if (me_arg->ts.u.derived->components->attr.class_pointer)
+ if (CLASS_DATA (me_arg)->attr.class_pointer)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must not"
" be POINTER", proc->name, &where);
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
{
gfc_symbol* super_type;
gfc_component *c;
- int i;
super_type = gfc_get_derived_super_type (sym);
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
- gfc_component *data;
- gfc_component *vptr;
- gfc_symbol *vtab;
- data = gfc_find_component (sym, "$data", true, true);
- 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)
{
- vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
+ gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
gcc_assert (vtab);
vptr->ts.u.derived = vtab->ts.u.derived;
}
return FAILURE;
}
+ /* F2008, C448. */
+ if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+ {
+ gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
+ "is not an array pointer", c->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->attr.proc_pointer && c->ts.interface)
{
if (c->ts.interface->attr.procedure && !sym->attr.vtype)
c->ts.u.cl = cl;
}
}
- else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
+ else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure pointer component "
"'%s' at %L must be explicit", c->ts.interface->name,
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
|| (me_arg->ts.type == BT_CLASS
- && me_arg->ts.u.derived->components->ts.u.derived != sym))
+ && CLASS_DATA (me_arg)->ts.u.derived != sym))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived type '%s'", me_arg->name, c->name,
}
/* 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 "
return FAILURE;
}
- if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer
- && c->ts.u.derived->components->ts.u.derived->components == NULL
- && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
+ if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
+ && CLASS_DATA (c)->ts.u.derived->components == NULL
+ && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
/* C437. */
if (c->ts.type == BT_CLASS
- && !(c->ts.u.derived->components->attr.pointer
- || c->ts.u.derived->components->attr.allocatable))
+ && !(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);
&& sym != c->ts.u.derived)
add_dt_to_dt_list (c->ts.u.derived);
- if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
- || c->as == NULL)
- continue;
-
- for (i = 0; i < c->as->rank; i++)
- {
- if (c->as->lower[i] == NULL
- || (resolve_index_expr (c->as->lower[i]) == FAILURE)
- || !gfc_is_constant_expr (c->as->lower[i])
- || c->as->upper[i] == NULL
- || (resolve_index_expr (c->as->upper[i]) == FAILURE)
- || !gfc_is_constant_expr (c->as->upper[i]))
- {
- gfc_error ("Component '%s' of '%s' at %L must have "
- "constant array bounds",
- c->name, sym->name, &c->loc);
- return FAILURE;
- }
- }
+ if (gfc_resolve_array_spec (c->as, !(c->attr.pointer
+ || c->attr.proc_pointer
+ || c->attr.allocatable)) == FAILURE)
+ return FAILURE;
}
/* Resolve the type-bound procedures. */
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
all DEFERRED bindings are overridden. */
if (super_type && super_type->attr.abstract && !sym->attr.abstract
+ && !sym->attr.is_class
&& ensure_not_abstract (sym, super_type) == FAILURE)
return FAILURE;
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);
- sym->refs--;
- if (!sym->refs)
- gfc_free_symbol (sym);
+ gfc_release_symbol (sym);
symtree->n.sym->refs++;
this_symtree->n.sym = symtree->n.sym;
return;
gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
if (sym->attr.procedure && sym->ts.interface
- && sym->attr.if_source != IFSRC_DECL)
+ && 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))
{
- 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;
- }
+ if (sym->attr.external)
+ gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
+ "at %L", &sym->declared_at);
+ else
+ gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
+ "at %L", &sym->declared_at);
- /* 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.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;
- }
+ return;
+ }
+
+
+ /* F2008, C530. */
+ if (sym->attr.contiguous
+ && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
+ && !sym->attr.pointer)))
+ {
+ gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
+ "array pointer or an assumed-shape array", sym->name,
+ &sym->declared_at);
+ return;
}
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
-
/* Make sure that the intrinsic is consistent with its internal
representation. This needs to be done before assigning a default
type to avoid spurious warnings. */
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
return;
+ /* Resolve associate names. */
+ if (sym->assoc)
+ resolve_assoc_var (sym, true);
+
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
{
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
+ sym->attr.contiguous = sym->result->attr.contiguous;
}
}
}
}
/* 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
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);
gfc_current_ns = old_ns;
cs_base = old_cs_base;
ns->resolved = 1;
+
+ gfc_run_passes (ns);
}
OSDN Git Service
