/* 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)))
+ && gfc_impure_variable (cons->expr->symtree->n.sym))
{
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);
+ gfc_error ("Invalid expression in the derived type constructor for pointer "
+ "component '%s' at %L in PURE procedure", comp->name,
+ &cons->expr->where);
}
}
/* 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,
/* Resolve a component-call expression. */
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;
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 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)
{
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);
resolve_compcall (e, &name);
ts = e->ts;
- /* 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)
{
return SUCCESS;
}
-/* 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)
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 FAILURE;
}
- /* Convert the case value kind to that of case expression kind, if needed.
- FIXME: Should a warning be issued? */
+ /* Convert the case value kind to that of case expression kind,
+ if needed */
+
if (e->ts.kind != case_expr->ts.kind)
gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
return;
}
+
+ /* Raise a warning if an INTEGER case value exceeds the range of
+ the case-expr. Later, all expressions will be promoted to the
+ largest kind of all case-labels. */
+
+ if (type == BT_INTEGER)
+ for (body = code->block; body; body = body->block)
+ for (cp = body->ext.case_list; cp; cp = cp->next)
+ {
+ if (cp->low
+ && gfc_check_integer_range (cp->low->value.integer,
+ case_expr->ts.kind) != ARITH_OK)
+ gfc_warning ("Expression in CASE statement at %L is "
+ "not in the range of %s", &cp->low->where,
+ gfc_typename (&case_expr->ts));
+
+ if (cp->high
+ && cp->low != cp->high
+ && gfc_check_integer_range (cp->high->value.integer,
+ case_expr->ts.kind) != ARITH_OK)
+ gfc_warning ("Expression in CASE statement at %L is "
+ "not in the range of %s", &cp->high->where,
+ gfc_typename (&case_expr->ts));
+ }
+
/* PR 19168 has a long discussion concerning a mismatch of the kinds
of the SELECT CASE expression and its CASE values. Walk the lists
of case values, and if we find a mismatch, promote case_expr to
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue;
- /* FIXME: Should a warning be issued? */
if (cp->low != NULL
&& case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
/* Deal with single value cases and case ranges. Errors are
issued from the validation function. */
- if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
- || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
+ if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
+ || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
{
t = FAILURE;
break;
value = cp->low->value.logical == 0 ? 2 : 1;
if (value & seen_logical)
{
- gfc_error ("constant logical value in CASE statement "
+ gfc_error ("Constant logical value in CASE statement "
"is repeated at %L",
&cp->low->where);
t = FAILURE;
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)
- selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = code->expr2->ts;
+ selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ }
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
&& 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))
+ for (cons = code->expr1->value.constructor; cons; cons = cons->next)
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 "
&& 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);
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;
}
&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))
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)))
+ if (c->attr.codimension
+ && (!c->attr.allocatable || c->as->type != AS_DEFERRED))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "
"deferred shape", c->name, &c->loc);
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_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. */
+ /* F2008, C528. */
else if (sym->attr.codimension && !sym->attr.allocatable
- && sym->as && sym->as->cotype == AS_DEFERRED)
+ && 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
gfc_try retval = SUCCESS;
mpz_init (frame.value);
+ mpz_init (trip);
start = gfc_copy_expr (var->iter.start);
end = gfc_copy_expr (var->iter.end);
if (gfc_simplify_expr (start, 1) == FAILURE
|| start->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator start at %L does not simplify", &start->where);
+ gfc_error ("start of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (end, 1) == FAILURE
|| end->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator end at %L does not simplify", &end->where);
+ gfc_error ("end of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (step, 1) == FAILURE
|| step->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator step at %L does not simplify", &step->where);
+ gfc_error ("step of implied-do loop at %L could not be "
+ "simplified to a constant value", &start->where);
retval = FAILURE;
goto cleanup;
}
- mpz_init_set (trip, end->value.integer);
+ mpz_set (trip, end->value.integer);
mpz_sub (trip, trip, start->value.integer);
mpz_add (trip, trip, step->value.integer);
{
if (traverse_data_var (var->list, where) == FAILURE)
{
- mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (e, 1) == FAILURE)
{
gfc_free_expr (e);
- mpz_clear (trip);
retval = FAILURE;
goto cleanup;
}
mpz_sub_ui (trip, trip, 1);
}
- mpz_clear (trip);
cleanup:
mpz_clear (frame.value);
+ mpz_clear (trip);
gfc_free_expr (start);
gfc_free_expr (end);
OSDN Git Service
