#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_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ sym->as->lower[i] = gfc_int_expr (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 (gfc_has_default_initializer (csym->ts.u.derived))
+ if (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 = gfc_constructor_first (expr->value.constructor);
+ cons = 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 && cons; comp = comp->next, cons = gfc_constructor_next (cons))
+ for (; comp; comp = comp->next, cons = cons->next)
{
int rank;
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- 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)
+ 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.codimension)
+ || a.asynchronous)
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)
{
- 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);
+ 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);
return SUCCESS;
}
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
{
- 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);
+ 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);
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. */
-static gfc_try
-gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
- int force_index_integer_kind)
+gfc_try
+gfc_resolve_index (gfc_expr *index, int check_scalar)
{
gfc_typespec ts;
&index->where) == FAILURE)
return FAILURE;
- if ((index->ts.kind != gfc_index_integer_kind
- && force_index_integer_kind)
+ if (index->ts.kind != gfc_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 + ar->codimen; i++)
+ for (i = 0; i < ar->dimen; i++)
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
- /* 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)
+ if (gfc_resolve_index (ar->start[i], check_scalar) == 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_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ start = gfc_int_expr (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_get_int_expr (gfc_default_integer_kind,
- NULL, 1));
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (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_get_int_expr (gfc_default_integer_kind, NULL,
- op1->value.character.length);
+ e1 = gfc_int_expr (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_get_int_expr (gfc_default_integer_kind, NULL,
- op2->value.character.length);
+ e2 = gfc_int_expr (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, const char **name)
+resolve_typebound_generic_call (gfc_expr* e)
{
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, const char **name)
+resolve_typebound_call (gfc_code* c)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
if (check_typebound_baseobject (c->expr1) == FAILURE)
return 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)
+ if (resolve_typebound_generic_call (c->expr1) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
}
-/* Resolve a component-call expression. */
+/* 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. */
static gfc_try
-resolve_compcall (gfc_expr* e, const char **name)
+resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (!e->value.compcall.tbp->function)
+ if (fcn && !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;
- /* 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)
+ if (resolve_typebound_generic_call (e) == 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 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);
+ /* 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;
}
}
-/* Resolve a typebound function, or 'method'. First separate all
- the non-CLASS references by calling resolve_compcall directly. */
+/* 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. */
static gfc_try
resolve_typebound_function (gfc_expr* e)
{
- gfc_symbol *declared;
- gfc_component *c;
+ gfc_symbol *derived, *declared;
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, NULL);
+ return resolve_compcall (e, true, false);
/* 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, NULL);
+ return resolve_compcall (e, true, false);
}
- c = gfc_find_component (declared, "$data", true, true);
- declared = c->ts.u.derived;
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (e->value.function.actual);
- /* 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;
+ /* Get the data component, which is of the declared type. */
+ derived = declared->components->ts.u.derived;
- /* 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;
+ /* 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);
- /* Then convert the expression to a procedure pointer component call. */
- e->value.function.esym = NULL;
- e->symtree = st;
+ class_try = (resolve_compcall (e, true, false) == SUCCESS)
+ ? class_try : FAILURE;
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- e->ref = new_ref;
- }
+ /* 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);
- /* '$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);
+ resolve_class_esym (e);
- /* 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;
+ /* 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 typebound subroutine, or 'method'. First separate all
- the non-CLASS references by calling resolve_typebound_call
- directly. */
+/* 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. */
static gfc_try
resolve_typebound_subroutine (gfc_code *code)
{
- gfc_symbol *declared;
- gfc_component *c;
+ gfc_symbol *derived, *declared;
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, NULL);
+ return resolve_typebound_call (code);
/* 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, NULL);
+ return resolve_typebound_call (code);
}
- c = gfc_find_component (declared, "$data", true, true);
- declared = c->ts.u.derived;
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (code->expr1->value.compcall.actual);
- /* 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;
+ /* Get the data component, which is of the declared type. */
+ derived = declared->components->ts.u.derived;
- resolve_typebound_call (code, &name);
- ts = code->expr1->ts;
+ class_try = SUCCESS;
+ fcn_flag = false;
+ list_e = gfc_copy_expr (code->expr1);
+ check_class_members (derived);
- /* Then convert the expression to a procedure pointer component call. */
- code->expr1->value.function.esym = NULL;
- code->expr1->symtree = st;
+ class_try = (resolve_typebound_call (code) == SUCCESS)
+ ? class_try : FAILURE;
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- code->expr1->ref = new_ref;
- }
+ /* 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);
- /* '$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);
+ resolve_class_esym (code->expr1);
- /* 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;
+ /* 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);
+
+ return class_try;
}
/* 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))
+ for (con = e->value.constructor; con; con = con->next)
{
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)
- goto failure;
+ return 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);
- goto failure;
+ return 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);
- goto failure;
+ return FAILURE;
}
/* Check F03:C632 and restriction following Note 6.18. */
if (code->expr3->rank > 0
&& conformable_arrays (code->expr3, e) == FAILURE)
- goto failure;
+ return 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);
- goto failure;
+ return 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);
- goto failure;
+ return FAILURE;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
sym->name, &e->where);
- goto failure;
+ return FAILURE;
}
if (!code->expr3)
}
}
- if (pointer || (dimension == 0 && codimension == 0))
- goto success;
+ if (pointer || dimension == 0)
+ return 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
- || (dimension && ref2->u.ar.dimen == 0))
+ if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
- goto failure;
+ return 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);
- goto failure;
+ return 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);
- 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;
+ return 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
return FAILURE;
}
- /* Convert the case value kind to that of case expression kind,
- if needed */
-
+ /* Convert the case value kind to that of case expression kind, if needed.
+ FIXME: Should a warning be issued? */
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;
ns = code->ext.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)
- {
- if (code->expr1->symtree->n.sym->attr.untyped)
- code->expr1->symtree->n.sym->ts = code->expr2->ts;
- selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
- }
+ selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
for (body = code->block; body; body = body->block)
{
c = body->ext.case_list;
-
+
if (c->ts.type == BT_DERIVED)
- c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
- c->ts.u.derived->hash_value);
-
+ c->low = c->high = gfc_int_expr (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, true);
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
}
}
-
-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))
- {
- /* 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;
- }
+ 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->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->current->next && stack->current->next->here == label)
+ break;
if (stack)
{
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
- && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+ && 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
- && 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_impure_variable (rhs->symtree->n.sym))
{
- gfc_error ("Assignment to coindexed variable at %L in a PURE "
- "procedure", &rhs->where);
+ 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;
}
}
/* 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_get_int_expr (gfc_default_integer_kind, NULL, 0));
+ gfc_replace_expr (cl->length, gfc_int_expr (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 + sym->as->corank; i++)
+ for (i = 0; i < sym->as->rank; 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_constant_expr (sym->ts.type, sym->ts.kind,
- &sym->declared_at);
-
+ 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;
+
/* 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. */
return FAILURE;
}
}
-
- /* Constraints on polymorphic variables. */
- if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
- {
- /* F03:C502. */
- if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
- {
- 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;
- }
-
- /* 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
- gfc_has_default_initializer because gfc_default_initializer generates
+ 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
- && gfc_has_default_initializer (sym->ts.u.derived)
+ && 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;
+ 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;
+ }
+ }
+
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
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.codimension) && !sym->attr.pointer
+ else if (sym->attr.dimension && !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);
- if (!overriding)
- return FAILURE;
- gcc_assert (overriding->n.tb);
+ gcc_assert (overriding && 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 && !sub->attr.abstract);
-
- if (!ancestor->attr.abstract)
- return SUCCESS;
+ gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
/* Walk bindings of this ancestor. */
if (ancestor->f2k_derived)
int i;
super_type = gfc_get_derived_super_type (sym);
-
- if (sym->attr.is_class && sym->ts.u.derived == NULL)
- {
- /* Fix up incomplete CLASS symbols. */
- gfc_component *data;
- gfc_component *vptr;
- gfc_symbol *vtab;
- data = gfc_find_component (sym, "$data", true, true);
- vptr = gfc_find_component (sym, "$vptr", true, true);
- if (vptr->ts.u.derived == NULL)
- {
- vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
- 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;
- }
-
if (c->attr.proc_pointer && c->ts.interface)
{
- if (c->ts.interface->attr.procedure && !sym->attr.vtype)
+ if (c->ts.interface->attr.procedure)
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)
{
- 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;
+ c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+ gfc_expr_replace_comp (c->ts.u.cl->length, c);
}
}
- else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
+ else if (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
- && !sym->attr.vtype)
+ if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
{
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 && !sym->attr.is_class
+ if (super_type
&& 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 (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
+ if (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
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)
{
{
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->cp_was_assumed)
+ && (sym->as->type == AS_ASSUMED_SIZE
|| 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);
}
- t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ 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 ("start of implied-do loop at %L could not be "
- "simplified to a constant value", &start->where);
+ gfc_error ("iterator start at %L does not simplify", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (end, 1) == FAILURE
|| end->expr_type != EXPR_CONSTANT)
{
- gfc_error ("end of implied-do loop at %L could not be "
- "simplified to a constant value", &start->where);
+ gfc_error ("iterator end at %L does not simplify", &end->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (step, 1) == FAILURE
|| step->expr_type != EXPR_CONSTANT)
{
- gfc_error ("step of implied-do loop at %L could not be "
- "simplified to a constant value", &start->where);
+ gfc_error ("iterator step at %L does not simplify", &step->where);
retval = FAILURE;
goto cleanup;
}
- mpz_set (trip, end->value.integer);
+ mpz_init_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);
return FAILURE;
}
- if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
+ if (sym->attr.in_common && 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_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ start = gfc_int_expr (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
