/* Perform type resolution on the various structures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "dependency.h"
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
+#include "constructor.h"
/* Types used in equivalence statements. */
/* We use bitmaps to determine if a branch target is valid. */
static bitmap_obstack labels_obstack;
+/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
+static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_int_expr (1);
+ sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
if (gfc_elemental (proc))
{
+ /* F2008, C1289. */
+ if (sym->attr.codimension)
+ {
+ gfc_error ("Coarray dummy argument '%s' at %L to elemental "
+ "procedure", sym->name, &sym->declared_at);
+ continue;
+ }
+
if (sym->as != NULL)
{
gfc_error ("Argument '%s' of elemental procedure at %L must "
}
-static bool
-has_default_initializer (gfc_symbol *der)
-{
- gfc_component *c;
-
- gcc_assert (der->attr.flavor == FL_DERIVED);
- for (c = der->components; c; c = c->next)
- if ((c->ts.type != BT_DERIVED && c->initializer)
- || (c->ts.type == BT_DERIVED
- && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
- break;
-
- return c != NULL;
-}
-
/* Resolve common variables. */
static void
resolve_common_vars (gfc_symbol *sym, bool named_common)
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"has an ultimate component that is "
"allocatable", csym->name, &csym->declared_at);
- if (has_default_initializer (csym->ts.u.derived))
+ if (gfc_has_default_initializer (csym->ts.u.derived))
gfc_error_now ("Derived type variable '%s' in COMMON at %L "
"may not have default initializer", csym->name,
&csym->declared_at);
symbol_attribute a;
t = SUCCESS;
- cons = expr->value.constructor;
+ 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
want. */
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
- && expr->ts.u.derived->ts.is_iso_c && cons && cons->expr != NULL)
+ && expr->ts.u.derived->ts.is_iso_c && cons
+ && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
{
gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
expr->ts.u.derived->name, &(expr->where));
return FAILURE;
}
- for (; comp; comp = comp->next, cons = cons->next)
+ /* Return if structure constructor is c_null_(fun)prt. */
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->ts.is_iso_c && cons
+ && cons->expr && cons->expr->expr_type == EXPR_NULL)
+ return SUCCESS;
+
+ for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (strcmp (comp->name, "$extends") == 0)
+ {
+ /* 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 = SUCCESS;
+ }
+ else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
t = gfc_convert_type (cons->expr, &comp->ts, 1);
}
+ /* 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 "
"for pointer component '%s' should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
+
+ /* F2003, C1272 (3). */
+ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
+ {
+ t = FAILURE;
+ gfc_error ("Invalid expression in the derived type constructor for "
+ "pointer component '%s' at %L in PURE procedure",
+ comp->name, &cons->expr->where);
+ }
}
return t;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
|| a.optional || a.pointer || a.save || a.target || a.volatile_
|| a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
- || a.asynchronous)
+ || a.asynchronous || a.codimension)
return 1;
return 0;
gfc_expr *e;
int save_need_full_assumed_size;
gfc_component *comp;
-
+
for (; arg; arg = arg->next)
{
e = arg->expr;
}
}
}
+
+ /* Fortran 2008, C1237. */
+ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ "component", &e->where);
+ return FAILURE;
+ }
}
return SUCCESS;
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))
{
- /* Make sure that translation for the gsymbol occurs before
- the procedure currently being resolved. */
- ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
- for (; ns && ns != gsym->ns; ns = ns->sibling)
- {
- if (ns->sibling == gsym->ns)
- {
- ns->sibling = gsym->ns->sibling;
- gsym->ns->sibling = gfc_global_ns_list;
- gfc_global_ns_list = gsym->ns;
- break;
- }
- }
+ gfc_symbol *def_sym;
+ /* Resolve the gsymbol namespace if needed. */
if (!gsym->ns->resolved)
{
gfc_dt_list *old_dt_list;
gfc_derived_types = old_dt_list;
}
- 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)
+ /* Make sure that translation for the gsymbol occurs before
+ the procedure currently being resolved. */
+ ns = gfc_global_ns_list;
+ for (; ns && ns != gsym->ns; ns = ns->sibling)
+ {
+ if (ns->sibling == gsym->ns)
+ {
+ ns->sibling = gsym->ns->sibling;
+ gsym->ns->sibling = gfc_global_ns_list;
+ gfc_global_ns_list = gsym->ns;
+ break;
+ }
+ }
+
+ def_sym = gsym->ns->proc_name;
+ if (def_sym->attr.entry_master)
+ {
+ 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. */
+ if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.u.cl;
+ long int l1 = 0, l2 = 0;
+ gfc_charlen *cl1 = sym->ts.u.cl;
+ gfc_charlen *cl2 = def_sym->ts.u.cl;
+
+ if (cl1 != NULL
+ && cl1->length != NULL
+ && cl1->length->expr_type == EXPR_CONSTANT)
+ l1 = mpz_get_si (cl1->length->value.integer);
+
+ if (cl2 != NULL
+ && cl2->length != NULL
+ && cl2->length->expr_type == EXPR_CONSTANT)
+ l2 = mpz_get_si (cl2->length->value.integer);
+
+ if (l1 && l2 && l1 != l2)
+ gfc_error ("Character length mismatch in return type of "
+ "function '%s' at %L (%ld/%ld)", sym->name,
+ &sym->declared_at, l1, l2);
+ }
- if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ /* Type mismatch of function return type and expected type. */
+ if (sym->attr.function
+ && !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 (&def_sym->ts));
+
+ if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
+ {
+ gfc_formal_arglist *arg = def_sym->formal;
+ for ( ; arg; arg = arg->next)
+ 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 "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
+ /* F2008, 12.4.2.2 (2c) */
+ else if (arg->sym->attr.codimension)
+ {
+ 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_error ("Nonconstant character-length function '%s' at %L "
- "must have an explicit interface", sym->name,
- &sym->declared_at);
+ 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_LEGACY)
- &&
- !(gfc_option.warn_std & GFC_STD_GNU)))
+ || ((gfc_option.warn_std & GFC_STD_LEGACY)
+ && !(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;
{
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)
}
/* If this ia a deferred TBP with an abstract interface (which may
- of course be referenced), expr->value.function.name will be set. */
- if (sym && sym->attr.abstract && !expr->value.function.name)
+ of course be referenced), expr->value.function.esym will be set. */
+ if (sym && sym->attr.abstract && !expr->value.function.esym)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
sym->name, &expr->where);
if (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
+ if (expr->value.function.isym && expr->value.function.isym->inquiry)
+ inquiry_argument = true;
no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+
if (resolve_actual_arglist (expr->value.function.actual,
p, no_formal_args) == FAILURE)
+ {
+ inquiry_argument = false;
return FAILURE;
+ }
+ inquiry_argument = false;
+
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
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
{
mpz_t last_value;
+ if (ar->dimen_type[i] == DIMEN_STAR)
+ {
+ gcc_assert (ar->stride[i] == NULL);
+ /* This implies [*] as [*:] and [*:3] are not possible. */
+ if (ar->start[i] == NULL)
+ {
+ gcc_assert (ar->end[i] == NULL);
+ return SUCCESS;
+ }
+ }
+
/* Given start, end and stride values, calculate the minimum and
maximum referenced indexes. */
case DIMEN_VECTOR:
break;
+ case DIMEN_STAR:
case DIMEN_ELEMENT:
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld < %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->lower[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld > %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->upper[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
return FAILURE;
}
+ /* ar->codimen == 0 is a local array. */
+ if (as->corank != ar->codimen && ar->codimen != 0)
+ {
+ gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
+ &ar->where, ar->codimen, as->corank);
+ return FAILURE;
+ }
+
for (i = 0; i < as->rank; i++)
if (check_dimension (i, ar, as) == FAILURE)
return FAILURE;
+ /* Local access has no coarray spec. */
+ if (ar->codimen != 0)
+ for (i = as->rank; i < as->rank + as->corank; i++)
+ {
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ {
+ gfc_error ("Coindex of codimension %d must be a scalar at %L",
+ i + 1 - as->rank, &ar->where);
+ return FAILURE;
+ }
+ if (check_dimension (i, ar, as) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
/* Resolve one part of an array index. */
-gfc_try
-gfc_resolve_index (gfc_expr *index, int check_scalar)
+static gfc_try
+gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
+ int force_index_integer_kind)
{
gfc_typespec ts;
&index->where) == FAILURE)
return FAILURE;
- if (index->ts.kind != gfc_index_integer_kind
+ if ((index->ts.kind != gfc_index_integer_kind
+ && force_index_integer_kind)
|| index->ts.type != BT_INTEGER)
{
gfc_clear_ts (&ts);
return SUCCESS;
}
+/* Resolve one part of an array index. */
+
+gfc_try
+gfc_resolve_index (gfc_expr *index, int check_scalar)
+{
+ return gfc_resolve_index_1 (index, check_scalar, 1);
+}
+
/* Resolve a dim argument to an intrinsic function. */
gfc_try
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = gfc_index_integer_kind;
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;
if (derived == NULL)
derived = e->symtree->n.sym->ts.u.derived;
+ if (derived->attr.is_class)
+ derived = derived->components->ts.u.derived;
+
c = derived->components;
for (; c; c = c->next)
int i, check_scalar;
gfc_expr *e;
- for (i = 0; i < ar->dimen; i++)
+ for (i = 0; i < ar->dimen + ar->codimen; i++)
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
- if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
+ /* Do not force gfc_index_integer_kind for the start. We can
+ do fine with any integer kind. This avoids temporary arrays
+ created for indexing with a vector. */
+ if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE)
return FAILURE;
if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
return FAILURE;
}
}
+ if (ar->type == AR_FULL && ar->as->rank == 0)
+ ar->type = AR_ELEMENT;
+
/* If the reference type is unknown, figure out what kind it is. */
if (ar->type == AR_UNKNOWN)
if (char_ref->u.ss.start)
start = gfc_copy_expr (char_ref->u.ss.start);
else
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
if (char_ref->u.ss.end)
end = gfc_copy_expr (char_ref->u.ss.end);
/* Length = (end - start +1). */
e->ts.u.cl->length = gfc_subtract (end, start);
- e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1));
e->ts.u.cl->length->ts.type = BT_INTEGER;
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
switch (ref->u.ar.type)
{
case AR_FULL:
+ /* Coarray scalar. */
+ if (ref->u.ar.as->rank == 0)
+ {
+ current_part_dimension = 0;
+ break;
+ }
+ /* Fall through. */
case AR_SECTION:
current_part_dimension = 1;
break;
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;
+ /* F2008, C617 and C1229. */
+ if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
+ && gfc_is_coindexed (e))
+ {
+ 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)
+ ref2 = ref;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ break;
+ }
+
+ for ( ; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ break;
+
+ /* Expression itself is coindexed object. */
+ if (ref == NULL)
+ {
+ gfc_component *c;
+ c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+ for ( ; c; c = c->next)
+ if (c->attr.allocatable && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Coindexed object with polymorphic allocatable "
+ "subcomponent at %L", &e->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
return t;
}
if (op1->ts.u.cl && op1->ts.u.cl->length)
e1 = gfc_copy_expr (op1->ts.u.cl->length);
else if (op1->expr_type == EXPR_CONSTANT)
- e1 = gfc_int_expr (op1->value.character.length);
+ e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ op1->value.character.length);
if (op2->ts.u.cl && op2->ts.u.cl->length)
e2 = gfc_copy_expr (op2->ts.u.cl->length);
else if (op2->expr_type == EXPR_CONSTANT)
- e2 = gfc_int_expr (op2->value.character.length);
+ e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ op2->value.character.length);
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
+ po->where = e->where;
}
if (gfc_resolve_expr (po) == FAILURE)
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
+ po->where = e->where;
/* Remove PPC reference. */
ref = &po->ref;
while ((*ref)->next)
- (*ref) = (*ref)->next;
+ ref = &(*ref)->next;
gfc_free_ref_list (*ref);
*ref = NULL;
}
+/* 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. */
static gfc_try
-resolve_typebound_generic_call (gfc_expr* e)
+resolve_typebound_generic_call (gfc_expr* e, const char **name)
{
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 = 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;
}
/* Resolve a call to a type-bound subroutine. */
static gfc_try
-resolve_typebound_call (gfc_code* c)
+resolve_typebound_call (gfc_code* c, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
if (check_typebound_baseobject (c->expr1) == FAILURE)
return FAILURE;
- if (resolve_typebound_generic_call (c->expr1) == FAILURE)
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = c->expr1->value.compcall.name;
+
+ if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
}
-/* Resolve a component-call expression. This originally was intended
- only to see functions. However, it is convenient to use it in
- resolving subroutine class methods, since we do not have to add a
- gfc_code each time. */
+/* Resolve a component-call expression. */
static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn)
+resolve_compcall (gfc_expr* e, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (fcn && !e->value.compcall.tbp->function)
+ if (!e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
- else if (!fcn && !e->value.compcall.tbp->subroutine)
- {
- /* To resolve class member calls, we borrow this bit
- of code to select the specific procedures. */
- gfc_error ("'%s' at %L should be a SUBROUTINE",
- e->value.compcall.name, &e->where);
- return FAILURE;
- }
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
- if (resolve_typebound_generic_call (e) == FAILURE)
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = e->value.compcall.name;
+
+ if (resolve_typebound_generic_call (e, name) == FAILURE)
return FAILURE;
gcc_assert (!e->value.compcall.tbp->is_generic);
return FAILURE;
e->value.function.actual = newactual;
- e->value.function.name = e->value.compcall.name;
+ e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
- e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
/* Resolution is not necessary if this is a class subroutine; this
function only has to identify the specific proc. Resolution of
the call will be done next in resolve_typebound_call. */
- return fcn ? gfc_resolve_expr (e) : SUCCESS;
+ return gfc_resolve_expr (e);
}
-/* Resolve a typebound call for the members in a class. This group of
- functions implements dynamic dispatch in the provisional version
- of f03 OOP. As soon as vtables are in place and contain pointers
- to methods, this will no longer be necessary. */
-static gfc_expr *list_e;
-static void check_class_members (gfc_symbol *);
-static gfc_try class_try;
-static bool fcn_flag;
-static gfc_symbol *class_object;
-
-
-static void
-check_members (gfc_symbol *derived)
-{
- if (derived->attr.flavor == FL_DERIVED)
- check_class_members (derived);
-}
+/* Resolve a typebound function, or 'method'. First separate all
+ the non-CLASS references by calling resolve_compcall directly. */
-static void
-check_class_members (gfc_symbol *derived)
+static gfc_try
+resolve_typebound_function (gfc_expr* e)
{
- gfc_expr *e;
- gfc_symtree *tbp;
- gfc_class_esym_list *etmp;
-
- e = gfc_copy_expr (list_e);
-
- tbp = gfc_find_typebound_proc (derived, &class_try,
- e->value.compcall.name,
- false, &e->where);
-
- if (tbp == NULL)
- {
- gfc_error ("no typebound available procedure named '%s' at %L",
- e->value.compcall.name, &e->where);
- return;
- }
-
- if (tbp->n.tb->is_generic)
- {
- /* If we have to match a passed class member, force the actual
- expression to have the correct type. */
- if (!tbp->n.tb->nopass)
- {
- if (e->value.compcall.base_object == NULL)
- e->value.compcall.base_object =
- extract_compcall_passed_object (e);
-
- e->value.compcall.base_object->ts.type = BT_DERIVED;
- e->value.compcall.base_object->ts.u.derived = derived;
- }
- }
-
- e->value.compcall.tbp = tbp->n.tb;
- e->value.compcall.name = tbp->name;
+ gfc_symbol *declared;
+ gfc_component *c;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+ const char *name;
+ gfc_typespec ts;
+ gfc_expr *expr;
- /* Let the original expresssion catch the assertion in
- resolve_compcall, since this flag does not appear to be reset or
- copied in some systems. */
- e->value.compcall.assign = 0;
+ st = e->symtree;
- /* Do the renaming, PASSing, generic => specific and other
- good things for each class member. */
- class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
- ? class_try : FAILURE;
+ /* 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)
+ {
+ /* 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_compcall (e, &name) == FAILURE)
+ return FAILURE;
- /* Now transfer the found symbol to the esym list. */
- if (class_try == SUCCESS)
- {
- etmp = list_e->value.function.class_esym;
- list_e->value.function.class_esym
- = gfc_get_class_esym_list();
- list_e->value.function.class_esym->next = etmp;
- list_e->value.function.class_esym->derived = derived;
- list_e->value.function.class_esym->esym
- = e->value.function.esym;
+ /* 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");
+ gfc_add_component_ref (e, name);
+ e->value.function.esym = NULL;
+ return SUCCESS;
}
- gfc_free_expr (e);
-
- /* Burrow down into grandchildren types. */
- if (derived->f2k_derived)
- gfc_traverse_ns (derived->f2k_derived, check_members);
-}
-
-
-/* Eliminate esym_lists where all the members point to the
- typebound procedure of the declared type; ie. one where
- type selection has no effect.. */
-static void
-resolve_class_esym (gfc_expr *e)
-{
- gfc_class_esym_list *p, *q;
- bool empty = true;
-
- gcc_assert (e && e->expr_type == EXPR_FUNCTION);
-
- p = e->value.function.class_esym;
- if (p == NULL)
- return;
-
- for (; p; p = p->next)
- empty = empty && (e->value.function.esym == p->esym);
-
- if (empty)
- {
- p = e->value.function.class_esym;
- for (; p; p = q)
- {
- q = p->next;
- gfc_free (p);
- }
- e->value.function.class_esym = NULL;
- }
-}
+ if (st == NULL)
+ return resolve_compcall (e, NULL);
+ if (resolve_ref (e) == FAILURE)
+ return FAILURE;
-/* Generate an expression for the hash value, given the reference to
- the class of the final expression (class_ref), the base of the
- full reference list (new_ref), the declared type and the class
- object (st). */
-static gfc_expr*
-hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
-{
- gfc_expr *hash_value;
+ /* Get the CLASS declared type. */
+ declared = get_declared_from_expr (&class_ref, &new_ref, e);
- /* Build an expression for the correct hash_value; ie. that of the last
- CLASS reference. */
- if (class_ref)
- {
- class_ref->next = NULL;
- }
- else
+ /* Weed out cases of the ultimate component being a derived type. */
+ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- new_ref = NULL;
+ return resolve_compcall (e, NULL);
}
- hash_value = gfc_get_expr ();
- hash_value->expr_type = EXPR_VARIABLE;
- hash_value->symtree = st;
- hash_value->symtree->n.sym->refs++;
- hash_value->ref = new_ref;
- gfc_add_component_ref (hash_value, "$vptr");
- gfc_add_component_ref (hash_value, "$hash");
-
- return hash_value;
-}
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
-/* 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;
- }
- }
+ /* Treat the call as if it is a typebound procedure, in order to roll
+ out the correct name for the specific function. */
+ if (resolve_compcall (e, &name) == FAILURE)
+ return FAILURE;
+ ts = e->ts;
- if (declared == NULL)
- declared = e->symtree->n.sym->ts.u.derived;
+ /* Then convert the expression to a procedure pointer component call. */
+ e->value.function.esym = NULL;
+ e->symtree = st;
- return declared;
-}
+ if (new_ref)
+ e->ref = new_ref;
+ /* '$vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_component_ref (e, "$vptr");
+ gfc_add_component_ref (e, name);
-/* Resolve the argument expressions so that any arguments expressions
- that include class methods are resolved before the current call.
- This is necessary because of the static variables used in CLASS
- method resolution. */
-static void
-resolve_arg_exprs (gfc_actual_arglist *arg)
-{
- /* Resolve the actual arglist expressions. */
- for (; arg; arg = arg->next)
- {
- if (arg->expr)
- gfc_resolve_expr (arg->expr);
- }
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ e->ts = ts;
+ return SUCCESS;
}
+/* Resolve a typebound subroutine, or 'method'. First separate all
+ the non-CLASS references by calling resolve_typebound_call
+ directly. */
-/* Resolve a CLASS typebound function, or 'method'. */
static gfc_try
-resolve_class_compcall (gfc_expr* e)
+resolve_typebound_subroutine (gfc_code *code)
{
- gfc_symbol *derived, *declared;
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
+ gfc_typespec ts;
+ gfc_expr *expr;
- st = e->symtree;
- class_object = st->n.sym;
+ st = code->expr1->symtree;
- /* Get the CLASS declared type. */
- declared = get_declared_from_expr (&class_ref, &new_ref, e);
+ /* 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;
- /* 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_compcall (e, true);
+ /* 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");
+ gfc_add_component_ref (code->expr1, name);
+ code->expr1->value.function.esym = NULL;
+ return SUCCESS;
}
- /* Resolve the argument expressions, */
- resolve_arg_exprs (e->value.function.actual);
-
- /* Get the data component, which is of the declared type. */
- derived = declared->components->ts.u.derived;
+ if (st == NULL)
+ return resolve_typebound_call (code, NULL);
- /* Resolve the function call for each member of the class. */
- class_try = SUCCESS;
- fcn_flag = true;
- list_e = gfc_copy_expr (e);
- check_class_members (derived);
-
- class_try = (resolve_compcall (e, true) == SUCCESS)
- ? class_try : FAILURE;
-
- /* Transfer the class list to the original expression. Note that
- the class_esym list is cleaned up in trans-expr.c, as the calls
- are translated. */
- e->value.function.class_esym = list_e->value.function.class_esym;
- list_e->value.function.class_esym = NULL;
- gfc_free_expr (list_e);
-
- resolve_class_esym (e);
-
- /* More than one typebound procedure so transmit an expression for
- the hash_value as the selector. */
- if (e->value.function.class_esym != NULL)
- e->value.function.class_esym->hash_value
- = hash_value_expr (class_ref, new_ref, st);
-
- return class_try;
-}
-
-/* Resolve a CLASS typebound subroutine, or 'method'. */
-static gfc_try
-resolve_class_typebound_call (gfc_code *code)
-{
- gfc_symbol *derived, *declared;
- gfc_ref *new_ref;
- gfc_ref *class_ref;
- gfc_symtree *st;
-
- st = code->expr1->symtree;
- class_object = st->n.sym;
+ 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)
+ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_typebound_call (code);
- }
-
- /* Resolve the argument expressions, */
- resolve_arg_exprs (code->expr1->value.compcall.actual);
-
- /* Get the data component, which is of the declared type. */
- derived = declared->components->ts.u.derived;
-
- class_try = SUCCESS;
- fcn_flag = false;
- list_e = gfc_copy_expr (code->expr1);
- check_class_members (derived);
+ return resolve_typebound_call (code, NULL);
+ }
- class_try = (resolve_typebound_call (code) == SUCCESS)
- ? class_try : FAILURE;
+ if (resolve_typebound_call (code, &name) == FAILURE)
+ return FAILURE;
+ ts = code->expr1->ts;
- /* Transfer the class list to the original expression. Note that
- the class_esym list is cleaned up in trans-expr.c, as the calls
- are translated. */
- code->expr1->value.function.class_esym
- = list_e->value.function.class_esym;
- list_e->value.function.class_esym = NULL;
- gfc_free_expr (list_e);
+ /* Then convert the expression to a procedure pointer component call. */
+ code->expr1->value.function.esym = NULL;
+ code->expr1->symtree = st;
- resolve_class_esym (code->expr1);
+ if (new_ref)
+ code->expr1->ref = new_ref;
- /* More than one typebound procedure so transmit an expression for
- the hash_value as the selector. */
- if (code->expr1->value.function.class_esym != NULL)
- code->expr1->value.function.class_esym->hash_value
- = hash_value_expr (class_ref, new_ref, st);
+ /* '$vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, name);
- return class_try;
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ code->expr1->ts = ts;
+ return SUCCESS;
}
}
+static bool
+gfc_is_expandable_expr (gfc_expr *e)
+{
+ gfc_constructor *con;
+
+ if (e->expr_type == EXPR_ARRAY)
+ {
+ /* Traverse the constructor looking for variables that are flavor
+ parameter. Parameters must be expanded since they are fully used at
+ compile time. */
+ con = gfc_constructor_first (e->value.constructor);
+ for (; con; con = gfc_constructor_next (con))
+ {
+ if (con->expr->expr_type == EXPR_VARIABLE
+ && con->expr->symtree
+ && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+ || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
+ return true;
+ if (con->expr->expr_type == EXPR_ARRAY
+ && gfc_is_expandable_expr (con->expr))
+ return true;
+ }
+ }
+
+ return false;
+}
+
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
+ bool inquiry_save;
if (e == NULL)
return SUCCESS;
+ /* inquiry_argument only applies to variables. */
+ inquiry_save = inquiry_argument;
+ if (e->expr_type != EXPR_VARIABLE)
+ inquiry_argument = false;
+
switch (e->expr_type)
{
case EXPR_OP:
break;
case EXPR_COMPCALL:
- if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- t = resolve_class_compcall (e);
- else
- t = resolve_compcall (e, true);
+ t = resolve_typebound_function (e);
break;
case EXPR_SUBSTRING:
if (t == SUCCESS)
{
expression_rank (e);
- gfc_expand_constructor (e);
+ if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
+ gfc_expand_constructor (e, false);
}
/* This provides the opportunity for the length of constructors with
character valued function elements to propagate the string length
to the expression. */
if (t == SUCCESS && e->ts.type == BT_CHARACTER)
- t = gfc_resolve_character_array_constructor (e);
+ {
+ /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
+ here rather then add a duplicate test for it above. */
+ gfc_expand_constructor (e, false);
+ t = gfc_resolve_character_array_constructor (e);
+ }
break;
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
fixup_charlen (e);
+ inquiry_argument = inquiry_save;
+
return t;
}
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
{
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);
+ return FAILURE;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
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)
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
- gfc_symbol *sym;
+ 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;
+ /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
+ checking of coarrays. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+
+ if (ref && ref->type == REF_ARRAY)
+ ref->u.ar.in_allocate = true;
+
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
+ codimension = attr.codimension;
}
else
{
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;
- 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
{
allocatable = sym->attr.allocatable;
pointer = sym->attr.pointer;
dimension = sym->attr.dimension;
+ codimension = sym->attr.codimension;
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
break;
case REF_COMPONENT:
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("Coindexed allocatable object at %L",
+ &e->where);
+ goto failure;
+ }
+
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;
- 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
{
allocatable = c->attr.allocatable;
pointer = c->attr.pointer;
dimension = c->attr.dimension;
+ codimension = c->attr.codimension;
is_abstract = c->attr.abstract;
}
break;
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
- return FAILURE;
+ goto failure;
}
/* Some checks for the SOURCE tag. */
{
gfc_error ("Type of entity at %L is type incompatible with "
"source-expr at %L", &e->where, &code->expr3->where);
- return FAILURE;
+ goto failure;
}
/* Check F03:C632 and restriction following Note 6.18. */
if (code->expr3->rank > 0
&& conformable_arrays (code->expr3, e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Check F03:C633. */
if (code->expr3->ts.kind != e->ts.kind)
gfc_error ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter",
&e->where, &code->expr3->where);
- return FAILURE;
+ 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);
- return FAILURE;
+ "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);
- return FAILURE;
+ goto failure;
}
+
+ if (!code->expr3 || code->expr3->mold)
+ {
+ /* Add default initializer for those derived types that need them. */
+ gfc_expr *init_e = NULL;
+ gfc_typespec ts;
- if (pointer || dimension == 0)
- return SUCCESS;
+ 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 (init_e)
+ {
+ 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;
+ }
+ }
+
+ if (pointer || (dimension == 0 && codimension == 0))
+ goto success;
/* Make sure the next-to-last reference node is an array specification. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
+ if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ || (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
- return FAILURE;
+ goto failure;
}
/* Make sure that the array section reference makes sense in the
ar = &ref2->u.ar;
+ if (codimension && ar->codimen == 0)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+
for (i = 0; i < ar->dimen; i++)
{
if (ref2->u.ar.type == AR_ELEMENT)
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
+ case DIMEN_STAR:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
- return FAILURE;
+ goto failure;
}
check_symbols:
-
for (a = code->ext.alloc.list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
gfc_error ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
- return FAILURE;
+ goto failure;
+ }
+ }
+ }
+
+ for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_ELEMENT
+ || ar->dimen_type[i] == DIMEN_RANGE)
+ {
+ if (i == (ar->dimen + ar->codimen - 1))
+ {
+ gfc_error ("Expected '*' in coindex specification in ALLOCATE "
+ "statement at %L", &e->where);
+ goto failure;
}
+ break;
}
+
+ if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
+ && ar->stride[i] == NULL)
+ break;
+
+ gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+ }
+
+ if (codimension && ar->as->rank == 0)
+ {
+ gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
+ "at %L", &e->where);
+ goto failure;
}
+success:
return SUCCESS;
+
+failure:
+ return FAILURE;
}
static void
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. */
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.
return FAILURE;
}
- /* Convert the case value kind to that of case expression kind, if needed.
- FIXME: Should a warning be issued? */
+ /* Convert the case value kind to that of case expression kind,
+ if needed */
+
if (e->ts.kind != case_expr->ts.kind)
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
return;
}
+
+ /* Raise a warning if an INTEGER case value exceeds the range of
+ the case-expr. Later, all expressions will be promoted to the
+ largest kind of all case-labels. */
+
+ if (type == BT_INTEGER)
+ for (body = code->block; body; body = body->block)
+ for (cp = body->ext.case_list; cp; cp = cp->next)
+ {
+ if (cp->low
+ && gfc_check_integer_range (cp->low->value.integer,
+ case_expr->ts.kind) != ARITH_OK)
+ gfc_warning ("Expression in CASE statement at %L is "
+ "not in the range of %s", &cp->low->where,
+ gfc_typename (&case_expr->ts));
+
+ if (cp->high
+ && cp->low != cp->high
+ && gfc_check_integer_range (cp->high->value.integer,
+ case_expr->ts.kind) != ARITH_OK)
+ gfc_warning ("Expression in CASE statement at %L is "
+ "not in the range of %s", &cp->high->where,
+ gfc_typename (&case_expr->ts));
+ }
+
/* PR 19168 has a long discussion concerning a mismatch of the kinds
of the SELECT CASE expression and its CASE values. Walk the lists
of case values, and if we find a mismatch, promote case_expr to
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue;
- /* FIXME: Should a warning be issued? */
if (cp->low != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
/* Deal with single value cases and case ranges. Errors are
issued from the validation function. */
- if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
- || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
+ if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
+ || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
{
t = FAILURE;
break;
value = cp->low->value.logical == 0 ? 2 : 1;
if (value & seen_logical)
{
- gfc_error ("constant logical value in CASE statement "
+ gfc_error ("Constant logical value in CASE statement "
"is repeated at %L",
&cp->low->where);
t = FAILURE;
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->ts.type != BT_CLASS
+ && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
+ {
+ gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+ "at %L", &code->loc);
+ return;
+ }
+
if (code->expr2)
- selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = code->expr2->ts;
+ 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)
else
ns->code->next = new_st;
code->op = EXEC_BLOCK;
+ code->ext.block.assoc = NULL;
code->expr1 = code->expr2 = NULL;
code->block = NULL;
for (body = code->block; body; body = body->block)
{
c = body->ext.case_list;
-
+
if (c->ts.type == BT_DERIVED)
- c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+ c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c->ts.u.derived->hash_value);
+
else if (c->ts.type == BT_UNKNOWN)
continue;
-
+
/* Assign temporary to selector. */
if (c->ts.type == BT_CLASS)
sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
tail->next = NULL;
default_case = tail;
}
-
+
/* More than one CLASS IS block? */
if (class_is->block)
{
}
}
+
+static void
+resolve_sync (gfc_code *code)
+{
+ /* Check imageset. The * case matches expr1 == NULL. */
+ if (code->expr1)
+ {
+ if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
+ gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
+ "INTEGER expression", &code->expr1->where);
+ if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
+ && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
+ gfc_error ("Imageset argument at %L must between 1 and num_images()",
+ &code->expr1->where);
+ else if (code->expr1->expr_type == EXPR_ARRAY
+ && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
+ {
+ gfc_constructor *cons;
+ cons = gfc_constructor_first (code->expr1->value.constructor);
+ for (; cons; cons = gfc_constructor_next (cons))
+ if (cons->expr->expr_type == EXPR_CONSTANT
+ && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
+ gfc_error ("Imageset argument at %L must between 1 and "
+ "num_images()", &cons->expr->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);
+
+ /* 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);
+}
+
+
/* Given a branch to a label, see if the branch is conforming.
The code node describes where the branch is located. */
the bitmap reachable_labels. */
if (bitmap_bit_p (cs_base->reachable_labels, label->value))
- return;
+ {
+ /* Check now whether there is a CRITICAL construct; if so, check
+ whether the label is still visible outside of the CRITICAL block,
+ which is invalid. */
+ for (stack = cs_base; stack; stack = stack->prev)
+ if (stack->current->op == EXEC_CRITICAL
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+ " at %L", &code->loc, &label->where);
+
+ return;
+ }
/* Step four: If we haven't found the label in the bitmap, it may
still be the label of the END of the enclosing block, in which
case we find it by going up the code_stack. */
for (stack = cs_base; stack; stack = stack->prev)
- if (stack->current->next && stack->current->next->here == label)
- break;
+ {
+ if (stack->current->next && stack->current->next->here == label)
+ break;
+ if (stack->current->op == EXEC_CRITICAL)
+ {
+ /* Note: A label at END CRITICAL does not leave the CRITICAL
+ construct as END CRITICAL is still part of it. */
+ gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+ " at %L", &code->loc, &label->where);
+ return;
+ }
+ }
if (stack)
{
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. */
+ /* For an ASSOCIATE block, the associations (and their targets) are already
+ resolved during gfc_resolve_symbol. */
- gfc_resolve (code->ext.ns);
+ /* Resolve the BLOCK's namespace. */
+ gfc_resolve (code->ext.block.ns);
}
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
and rhs is the same symbol as the lhs. */
if ((*rhsptr)->expr_type == EXPR_VARIABLE
&& (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
- && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+ && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
&& (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
*rhsptr = gfc_get_parentheses (*rhsptr);
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
- && gfc_impure_variable (rhs->symtree->n.sym))
+ && rhs->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ {
+ /* F2008, C1283. */
+ if (gfc_is_coindexed (rhs))
+ gfc_error ("Coindexed expression at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure",
+ &rhs->where);
+ else
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &rhs->where);
+ return rval;
+ }
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
{
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
- &rhs->where);
+ gfc_error ("Assignment to coindexed variable at %L in a PURE "
+ "procedure", &rhs->where);
return rval;
}
}
/* 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. */
if (lhs->ts.type == BT_CLASS)
{
gfc_error ("Variable must not be polymorphic in assignment at %L",
return false;
}
+ /* F2008, Section 7.2.1.2. */
+ if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+ {
+ gfc_error ("Coindexed variable must not be have an allocatable ultimate "
+ "component in assignment at %L", &lhs->where);
+ return false;
+ }
+
gfc_check_assign (lhs, rhs, 1);
return false;
}
case EXEC_OMP_DO:
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;
+ break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
case EXEC_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
+ case EXEC_ERROR_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_ASSIGN_CALL:
+ case EXEC_CRITICAL:
+ break;
+
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
+ resolve_sync (code);
break;
case EXEC_ENTRY:
case EXEC_COMPCALL:
compcall:
- if (code->expr1->symtree
- && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
- resolve_class_typebound_call (code);
- else
- resolve_typebound_call (code);
+ resolve_typebound_subroutine (code);
break;
case EXEC_CALL_PPC:
break;
case EXEC_BLOCK:
- gfc_resolve (code->ext.ns);
+ gfc_resolve (code->ext.block.ns);
break;
case EXEC_DO:
value, the length of character entities declared is zero." */
if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
{
- gfc_warning_now ("CHARACTER variable has zero length at %L",
- &cl->length->where);
- gfc_replace_expr (cl->length, gfc_int_expr (0));
+ if (gfc_option.warn_surprising)
+ gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
+ " the length has been set to zero",
+ &cl->length->where, i);
+ gfc_replace_expr (cl->length,
+ gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
}
/* Check that the character length is not too large. */
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
has not been simplified; parameter array references. Do the
simplification now. */
- for (i = 0; i < sym->as->rank; i++)
+ for (i = 0; i < sym->as->rank + sym->as->corank; i++)
{
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
not_constant = true;
-
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
return NULL;
/* Now we'll try to build an initializer expression. */
- init_expr = gfc_get_expr ();
- init_expr->expr_type = EXPR_CONSTANT;
- init_expr->ts.type = sym->ts.type;
- init_expr->ts.kind = sym->ts.kind;
- init_expr->where = sym->declared_at;
-
+ init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
+ &sym->declared_at);
+
/* We will only initialize integers, reals, complex, logicals, and
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
{
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:
return FAILURE;
}
}
+
+ /* Constraints on polymorphic variables. */
+ if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
+ {
+ /* F03:C502. */
+ 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",
+ 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)
+ {
+ gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
+ "or pointer", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
return SUCCESS;
}
or POINTER attribute, the object shall have the SAVE attribute."
The check for initializers is performed with
- has_default_initializer because gfc_default_initializer generates
+ gfc_has_default_initializer because gfc_default_initializer generates
a hidden default for allocatable components. */
if (!(sym->value || no_init_flag) && sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable
- && has_default_initializer (sym->ts.u.derived))
- {
- gfc_error("Object '%s' at %L must have the SAVE attribute for "
- "default initialization of a component",
- sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- if (sym->ts.type == BT_CLASS)
- {
- /* C502. */
- if (!gfc_type_is_extensible (sym->ts.u.derived->components->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);
- return FAILURE;
- }
-
- /* C509. */
- /* Assume that use associated symbols were checked in the module ns. */
- if (!sym->attr.class_ok && !sym->attr.use_assoc)
- {
- gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
- "or pointer", sym->name, &sym->declared_at);
- return FAILURE;
- }
- }
+ && gfc_has_default_initializer (sym->ts.u.derived)
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for "
+ "module variable '%s' at %L, needed due to "
+ "the default initialization", sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
no_init_flag = 1;
- else if (sym->attr.dimension && !sym->attr.pointer
+ else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
no_init_flag = automatic_flag = 1;
{
gfc_formal_arglist *arg;
- if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
- gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
- "interfaces", sym->name, &sym->declared_at);
-
if (sym->attr.function
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, sym2->name, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
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);
{
gfc_symtree* overriding;
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
- gcc_assert (overriding && overriding->n.tb);
+ if (!overriding)
+ return FAILURE;
+ gcc_assert (overriding->n.tb);
if (overriding->n.tb->deferred)
{
gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
This is not the most efficient way to do this, but it should be ok and is
clearer than something sophisticated. */
- gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
+ gcc_assert (ancestor && !sub->attr.abstract);
+
+ if (!ancestor->attr.abstract)
+ return SUCCESS;
/* Walk bindings of this ancestor. */
if (ancestor->f2k_derived)
{
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_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);
+ gcc_assert (vtab);
+ vptr->ts.u.derived = vtab->ts.u.derived;
+ }
+ }
+
+ /* F2008, C432. */
+ if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+ {
+ gfc_error ("As extending type '%s' at %L has a coarray component, "
+ "parent type '%s' shall also have one", sym->name,
+ &sym->declared_at, super_type->name);
+ return FAILURE;
+ }
/* Ensure the extended type gets resolved before we do. */
if (super_type && resolve_fl_derived (super_type) == FAILURE)
for (c = sym->components; c != NULL; c = c->next)
{
+ /* F2008, C442. */
+ if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
+ && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
+ {
+ gfc_error ("Coarray component '%s' at %L must be allocatable with "
+ "deferred shape", c->name, &c->loc);
+ return FAILURE;
+ }
+
+ /* F2008, C443. */
+ if (c->attr.codimension && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->ts.is_iso_c)
+ {
+ gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ "shall not be a coarray", c->name, &c->loc);
+ return FAILURE;
+ }
+
+ /* F2008, C444. */
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+ && (c->attr.codimension || c->attr.pointer || c->attr.dimension
+ || c->attr.allocatable))
+ {
+ gfc_error ("Component '%s' at %L with coarray component "
+ "shall be a nonpointer, nonallocatable scalar",
+ c->name, &c->loc);
+ 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)
+ if (c->ts.interface->attr.procedure && !sym->attr.vtype)
gfc_error ("Interface '%s', used by procedure pointer component "
"'%s' at %L, is declared in a later PROCEDURE statement",
c->ts.interface->name, c->name, &c->loc);
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
- c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- gfc_expr_replace_comp (c->ts.u.cl->length, c);
+ gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+ gfc_expr_replace_comp (cl->length, c);
+ if (cl->length && !cl->resolved
+ && gfc_resolve_expr (cl->length) == FAILURE)
+ return FAILURE;
+ c->ts.u.cl = cl;
}
}
- else if (c->ts.interface->name[0] != '\0')
+ 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,
}
/* Procedure pointer components: Check PASS arg. */
- if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
+ if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
+ && !sym->attr.vtype)
{
gfc_symbol* me_arg;
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,
&& resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
return FAILURE;
+ /* If this type is an extension, set the accessibility of the parent
+ component. */
+ if (super_type && c == sym->components
+ && strcmp (super_type->name, c->name) == 0)
+ c->attr.access = super_type->attr.access;
+
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
- if (super_type
+ if (super_type && !sym->attr.is_class
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
}
}
- if (c->ts.type == BT_DERIVED && c->attr.pointer
+ if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
&& c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
{
return FAILURE;
}
+ 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,
+ &c->loc);
+ return FAILURE;
+ }
+
/* 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_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)
{
{
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;
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->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')
}
}
+ if (sym->attr.is_protected && !sym->attr.proc_pointer
+ && (sym->attr.procedure || sym->attr.external))
+ {
+ 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);
+
+ 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)
return;
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;
+ /* For associate names, resolve corresponding expression and make sure
+ they get their type-spec set this way. */
+ 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);
+ }
+
/* 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;
}
}
}
arguments. */
if (sym->as != NULL
- && (sym->as->type == AS_ASSUMED_SIZE
+ && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
}
}
+ /* F2008, C526. */
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || sym->attr.codimension)
+ && sym->attr.result)
+ gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+ "a coarray component", sym->name, &sym->declared_at);
+
+ /* F2008, C524. */
+ if (sym->attr.codimension && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->ts.is_iso_c)
+ gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ "shall not be a coarray", sym->name, &sym->declared_at);
+
+ /* F2008, C525. */
+ if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
+ && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
+ || sym->attr.allocatable))
+ gfc_error ("Variable '%s' at %L with coarray component "
+ "shall be a nonpointer, nonallocatable scalar",
+ sym->name, &sym->declared_at);
+
+ /* F2008, C526. The function-result case was handled above. */
+ 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->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program
+ || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
+ gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
+ "component and is not ALLOCATABLE, SAVE nor a "
+ "dummy argument", sym->name, &sym->declared_at);
+ /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
+ else if (sym->attr.codimension && !sym->attr.allocatable
+ && sym->as && sym->as->cotype == AS_DEFERRED)
+ gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
+ "deferred shape", sym->name, &sym->declared_at);
+ else if (sym->attr.codimension && sym->attr.allocatable
+ && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
+ gfc_error ("Allocatable coarray variable '%s' at %L must have "
+ "deferred shape", sym->name, &sym->declared_at);
+
+
+ /* F2008, C541. */
+ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+ || (sym->attr.codimension && sym->attr.allocatable))
+ && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+ gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+ "allocatable coarray or have coarray components",
+ sym->name, &sym->declared_at);
+
+ if (sym->attr.codimension && sym->attr.dummy
+ && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
+ gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+ "procedure '%s'", sym->name, &sym->declared_at,
+ sym->ns->proc_name->name);
+
switch (sym->attr.flavor)
{
case FL_VARIABLE:
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)
mpz_set_ui (size, 0);
}
- gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
+ offset, range);
mpz_add (offset, offset, range);
mpz_clear (range);
+
+ if (t == FAILURE)
+ break;
}
/* Assign initial value to symbol. */
gfc_try retval = SUCCESS;
mpz_init (frame.value);
+ mpz_init (trip);
start = gfc_copy_expr (var->iter.start);
end = gfc_copy_expr (var->iter.end);
if (gfc_simplify_expr (start, 1) == FAILURE
|| start->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator start at %L does not simplify", &start->where);
+ gfc_error ("start of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (end, 1) == FAILURE
|| end->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator end at %L does not simplify", &end->where);
+ gfc_error ("end of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (step, 1) == FAILURE
|| step->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator step at %L does not simplify", &step->where);
+ gfc_error ("step of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
- mpz_init_set (trip, end->value.integer);
+ mpz_set (trip, end->value.integer);
mpz_sub (trip, trip, start->value.integer);
mpz_add (trip, trip, step->value.integer);
{
if (traverse_data_var (var->list, where) == FAILURE)
{
- mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (e, 1) == FAILURE)
{
gfc_free_expr (e);
- mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
mpz_sub_ui (trip, trip, 1);
}
- mpz_clear (trip);
cleanup:
mpz_clear (frame.value);
+ mpz_clear (trip);
gfc_free_expr (start);
gfc_free_expr (end);
gfc_impure_variable (gfc_symbol *sym)
{
gfc_symbol *proc;
+ gfc_namespace *ns;
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
- if (sym->ns != gfc_current_ns)
- return !sym->attr.function;
+ /* Check if the symbol's ns is inside the pure procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ if (ns == sym->ns)
+ break;
+ if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+ return 1;
+ }
proc = sym->ns->proc_name;
if (sym->attr.dummy && gfc_pure (proc)
}
-/* Test whether a symbol is pure or not. For a NULL pointer, checks the
- symbol of the current procedure. */
+/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
+ current namespace is inside a pure procedure. */
int
gfc_pure (gfc_symbol *sym)
{
symbol_attribute attr;
+ gfc_namespace *ns;
if (sym == NULL)
- sym = gfc_current_ns->proc_name;
- if (sym == NULL)
- return 0;
+ {
+ /* Check if the current namespace or one of its parents
+ belongs to a pure procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
+ return 1;
+ }
+ return 0;
+ }
attr = sym->attr;
return FAILURE;
}
- if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived))
+ if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
{
gfc_error ("Derived type variable '%s' at %L with default "
"initialization cannot be in EQUIVALENCE with a variable "
{
ref->type = REF_SUBSTRING;
if (start == NULL)
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
ref->u.ss.start = start;
if (end == NULL && e->ts.u.cl)
end = gfc_copy_expr (e->ts.u.cl->length);
gfc_current_ns = old_ns;
cs_base = old_cs_base;
ns->resolved = 1;
+
+ gfc_run_passes (ns);
}
OSDN Git Service
