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,
/* Non-assumed length character functions. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ && gsym->ns->proc_name->ts.u.cl != NULL
+ && gsym->ns->proc_name->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
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 gfc_try 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)
+ (void) check_class_members (derived);
+}
+
+
+static gfc_try
+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 FAILURE;
+ }
+
+ /* 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 (e->value.compcall.base_object == NULL)
+ return FAILURE;
+
+ 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);
+
+ return SUCCESS;
+}
+
+
+/* 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);
- /* Then convert the expression to a procedure pointer component call. */
- e->value.function.esym = NULL;
- e->symtree = st;
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- e->ref = new_ref;
- }
+ class_try = (resolve_compcall (e, true, false) == SUCCESS)
+ ? class_try : FAILURE;
- /* '$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);
+ /* 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);
- /* 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_class_esym (e);
+
+ /* More than one typebound procedure so transmit an expression for
+ the hash_value as the selector. */
+ if (e->value.function.class_esym != NULL)
+ e->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
+
+ return class_try;
}
-/* Resolve a 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);
- /* Then convert the expression to a procedure pointer component call. */
- code->expr1->value.function.esym = NULL;
- code->expr1->symtree = st;
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
- if (class_ref)
- {
- gfc_free_ref_list (class_ref->next);
- code->expr1->ref = new_ref;
- }
+ class_try = (resolve_typebound_call (code) == SUCCESS)
+ ? class_try : FAILURE;
- /* '$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);
+ /* 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);
- /* 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;
+ resolve_class_esym (code->expr1);
+
+ /* 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;
}
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;
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);
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);
c->ts.u.cl = cl;
}
}
- 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
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);
OSDN Git Service
