aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/resolve.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/resolve.cc')
-rw-r--r--gcc/fortran/resolve.cc89
1 files changed, 42 insertions, 47 deletions
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 1e62e94..4a6e951 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -533,7 +533,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc)
}
}
}
-
+ if (sym)
+ sym->formal_resolved = 1;
gfc_current_ns = orig_current_ns;
}
@@ -3472,7 +3473,7 @@ resolve_function (gfc_expr *expr)
&expr->where, &sym->formal_at);
}
}
- else
+ else if (!sym->formal_resolved)
{
gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual);
sym->formal_at = expr->where;
@@ -4033,7 +4034,7 @@ resolve_call (gfc_code *c)
&c->loc, &csym->formal_at);
}
}
- else
+ else if (!csym->formal_resolved)
{
gfc_get_formal_from_actual_arglist (csym, c->ext.actual);
csym->formal_at = c->loc;
@@ -4806,34 +4807,6 @@ resolve_operator (gfc_expr *e)
return false;
}
}
-
- /* coranks have to be equal or one has to be zero to be combinable. */
- if (op1->corank == op2->corank || (op1->corank != 0 && op2->corank == 0))
- {
- e->corank = op1->corank;
- /* Only do this, when regular array has not set a shape yet. */
- if (e->shape == NULL)
- {
- if (op1->corank != 0)
- {
- e->shape = gfc_copy_shape (op1->shape, op1->corank);
- }
- }
- }
- else if (op1->corank == 0 && op2->corank != 0)
- {
- e->corank = op2->corank;
- /* Only do this, when regular array has not set a shape yet. */
- if (e->shape == NULL)
- e->shape = gfc_copy_shape (op2->shape, op2->corank);
- }
- else
- {
- gfc_error ("Inconsistent coranks for operator at %L and %L",
- &op1->where, &op2->where);
- return false;
- }
-
break;
case INTRINSIC_PARENTHESES:
@@ -6069,8 +6042,8 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
gfc_expression_rank (op2);
return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank)
- && (op1->corank == 0 || op2->corank == 0
- || op1->corank == op2->corank);
+ && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank
+ || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2)));
}
/* Resolve a variable expression. */
@@ -8739,8 +8712,25 @@ static bool
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
{
gfc_ref *tail;
+ bool scalar;
+
for (tail = e2->ref; tail && tail->next; tail = tail->next);
+ /* If MOLD= is present and is not scalar, and the allocate-object has an
+ explicit-shape-spec, the ranks need not agree. This may be unintended,
+ so let's emit a warning if -Wsurprising is given. */
+ scalar = !tail || tail->type == REF_COMPONENT;
+ if (e1->mold && e1->rank > 0
+ && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
+ {
+ if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
+ gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
+ "but MOLD= expression at %L has rank %d",
+ &e2->where, scalar ? 0 : tail->u.ar.as->rank,
+ &e1->where, e1->rank);
+ return true;
+ }
+
/* First compare rank. */
if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
|| (!tail && e1->rank != e2->rank))
@@ -10801,6 +10791,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
ref = gfc_copy_ref (ref);
}
+ gfc_expr *orig_expr1 = code->expr1;
+
/* Add EXEC_SELECT to switch on type. */
new_st = gfc_get_code (code->op);
new_st->expr1 = code->expr1;
@@ -10828,7 +10820,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
for (body = code->block; body; body = body->block)
{
gfc_symbol *vtab;
- gfc_expr *e;
c = body->ext.block.case_list;
/* Generate an index integer expression for address of the
@@ -10836,6 +10827,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
is stored in c->high and is used to resolve intrinsic cases. */
if (c->ts.type != BT_UNKNOWN)
{
+ gfc_expr *e;
if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
vtab = gfc_find_derived_vtab (c->ts.u.derived);
@@ -10868,11 +10860,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
when this case is actually true, so build a new ASSOCIATE
that does precisely this here (instead of using the
'global' one). */
-
+ const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1);
if (c->ts.type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_class_%s_%s",
+ c->ts.u.derived->name, var_name);
else if (c->ts.type == BT_DERIVED)
- sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_type_%s_%s",
+ c->ts.u.derived->name, var_name);
else if (c->ts.type == BT_CHARACTER)
{
HOST_WIDE_INT charlen = 0;
@@ -10880,12 +10874,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
- gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
+ "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
+ gfc_basic_typename (c->ts.type), charlen, c->ts.kind,
+ var_name);
}
else
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
- c->ts.kind);
+ snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
+ gfc_basic_typename (c->ts.type), c->ts.kind, var_name);
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
@@ -16818,8 +16813,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
return false;
/* Now add the caf token field, where needed. */
- if (flag_coarray != GFC_FCOARRAY_NONE
- && !sym->attr.is_class && !sym->attr.vtype)
+ if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class
+ && !sym->attr.vtype)
{
for (c = sym->components; c; c = c->next)
if (!c->attr.dimension && !c->attr.codimension
@@ -18058,16 +18053,16 @@ skip_interfaces:
|| (a->dummy && !a->pointer && a->intent == INTENT_OUT
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
apply_default_init (sym);
+ else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc
+ && sym->result)
+ /* Default initialization for function results. */
+ apply_default_init (sym->result);
else if (a->function && sym->result && a->access != ACCESS_PRIVATE
&& (sym->ts.u.derived->attr.alloc_comp
|| sym->ts.u.derived->attr.pointer_comp))
/* Mark the result symbol to be referenced, when it has allocatable
components. */
sym->result->attr.referenced = 1;
- else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc
- && sym->result)
- /* Default initialization for function results. */
- apply_default_init (sym->result);
}
if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
generated by cgit v1.1 at 2025-07-04 14:43:02 +0000