}
+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);
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;
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);
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))
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_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)
{
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 "
OSDN Git Service
