#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 "
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. */
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS;
- for (; comp; comp = comp->next, cons = cons->next)
+ 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,
"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;
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)
{
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
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;
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);
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;
if (matches)
{
e->value.compcall.tbp = g->specific;
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = g->specific_st->name;
goto 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, bool class_members)
+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);
e->value.function.actual = newactual;
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;
e->expr_type = EXPR_FUNCTION;
- /* Resolution is not necessary when constructing component calls
- for class members, since this must only be done for the
- declared type, which is done afterwards. */
- return !class_members ? gfc_resolve_expr (e) : SUCCESS;
-}
-
-
-/* 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 void
-check_members (gfc_symbol *derived)
-{
- if (derived->attr.flavor == FL_DERIVED)
- check_class_members (derived);
-}
-
-
-static void
-check_class_members (gfc_symbol *derived)
-{
- 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 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);
-
- if (!derived->attr.abstract)
- {
- 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;
-
- /* 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;
-
- /* Do the renaming, PASSing, generic => specific and other
- good things for each class member. */
- class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
- ? class_try : 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;
- }
-
- 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;
- }
-}
-
-
-/* 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;
-
- /* Build an expression for the correct hash_value; ie. that of the last
- CLASS reference. */
- if (class_ref)
- {
- class_ref->next = NULL;
- }
- else
- {
- gfc_free_ref_list (new_ref);
- new_ref = 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;
+ /* 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 gfc_resolve_expr (e);
}
}
-/* 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);
- }
-}
-
-
-/* Resolve a typebound function, or 'method'. First separate all
- the non-CLASS references by calling resolve_compcall directly.
- Then treat the CLASS references by resolving for each of the class
- members in turn. */
+/* Resolve a typebound function, or 'method'. First separate all
+ the non-CLASS references by calling resolve_compcall directly. */
static gfc_try
resolve_typebound_function (gfc_expr* e)
{
- gfc_symbol *derived, *declared;
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
+ const char *genname;
+ gfc_typespec ts;
st = e->symtree;
if (st == NULL)
- return resolve_compcall (e, true, false);
+ return resolve_compcall (e, NULL);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* 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))
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_compcall (e, true, false);
+ return resolve_compcall (e, NULL);
}
- /* 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;
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
- /* 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);
+ /* 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;
- class_try = (resolve_compcall (e, true, false) == SUCCESS)
- ? class_try : FAILURE;
+ /* 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);
+ ts = e->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. */
- e->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. */
+ e->value.function.esym = NULL;
+ e->symtree = st;
- resolve_class_esym (e);
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ e->ref = new_ref;
+ }
- /* 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);
+ /* '$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);
+ }
+ gfc_add_component_ref (e, 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. */
+ e->ts = ts;
+ return SUCCESS;
}
-/* Resolve a typebound subroutine, or 'method'. First separate all
- the non-CLASS references by calling resolve_typebound_call directly.
- Then treat the CLASS references by resolving for each of the class
- members in turn. */
+/* Resolve a typebound subroutine, or 'method'. First separate all
+ the non-CLASS references by calling resolve_typebound_call
+ directly. */
static gfc_try
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 *genname;
+ const char *name;
+ gfc_typespec ts;
st = code->expr1->symtree;
if (st == NULL)
- return resolve_typebound_call (code);
+ return resolve_typebound_call (code, NULL);
/* Get the CLASS declared type. */
declared = 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)
- || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_typebound_call (code);
+ return resolve_typebound_call (code, NULL);
}
- /* Resolve the argument expressions, */
- resolve_arg_exprs (code->expr1->value.compcall.actual);
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
- /* Get the data component, which is of the declared type. */
- derived = declared->components->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;
- class_try = SUCCESS;
- fcn_flag = false;
- list_e = gfc_copy_expr (code->expr1);
- check_class_members (derived);
+ resolve_typebound_call (code, &name);
+ ts = code->expr1->ts;
- class_try = (resolve_typebound_call (code) == SUCCESS)
- ? class_try : FAILURE;
+ /* Then convert the expression to a procedure pointer component call. */
+ code->expr1->value.function.esym = NULL;
+ code->expr1->symtree = st;
- /* 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);
-
- resolve_class_esym (code->expr1);
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ 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");
+ 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);
+ }
+ 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;
}
/* Traverse the constructor looking for variables that are flavor
parameter. Parameters must be expanded since they are fully used at
compile time. */
- for (con = e->value.constructor; con; con = con->next)
+ 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
+ && (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))
+ && gfc_is_expandable_expr (con->expr))
return true;
}
}
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:
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
fixup_charlen (e);
+ inquiry_argument = inquiry_save;
+
return t;
}
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;
/* 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
{
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;
}
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;
+ codimension = c->ts.u.derived->components->attr.codimension;
is_abstract = c->ts.u.derived->components->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)
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;
+ 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)
}
}
- if (pointer || dimension == 0)
- return SUCCESS;
+ 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 (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)
{
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);
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
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);
}
}
+
+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)
{
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
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_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:
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_int_expr (0));
+ 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. */
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_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"
super_type = gfc_get_derived_super_type (sym);
+ /* 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)
return 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;
+ }
+
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 (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
{
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 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 && 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)
+ {
+ 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
{
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')
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. */
{
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);
OSDN Git Service
