===================================================================
@@ -635,40 +635,69 @@
return ret;
}
+/* Calculate the length of a character variable, including substrings.
+ Strip away parentheses if necessary. Return -1 if no length could
+ be determined. */
+static long
+gfc_var_strlen (const gfc_expr *a)
+{
+ gfc_ref *ra;
+
+ while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
+ a = a->value.op.op1;
+
+ for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
+ ;
+
+ if (ra)
+ {
+ long start_a, end_a;
+
+ if (ra->u.ss.start->expr_type == EXPR_CONSTANT
+ && ra->u.ss.end->expr_type == EXPR_CONSTANT)
+ {
+ start_a = mpz_get_si (ra->u.ss.start->value.integer);
+ end_a = mpz_get_si (ra->u.ss.end->value.integer);
+ return end_a - start_a + 1;
+ }
+ else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+ return 1;
+ else
+ return -1;
+ }
+
+ if (a->ts.u.cl && a->ts.u.cl->length
+ && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ return mpz_get_si (a->ts.u.cl->length->value.integer);
+ else if (a->expr_type == EXPR_CONSTANT
+ && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
+ return a->value.character.length;
+ else
+ return -1;
+
+}
+
/* Check whether two character expressions have the same length;
- returns SUCCESS if they have or if the length cannot be determined. */
+ returns SUCCESS if they have or if the length cannot be determined,
+ otherwise return FAILURE and raise a gfc_error. */
gfc_try
gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
{
long len_a, len_b;
- len_a = len_b = -1;
- if (a->ts.u.cl && a->ts.u.cl->length
- && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
- len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
- else if (a->expr_type == EXPR_CONSTANT
- && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
- len_a = a->value.character.length;
- else
+ len_a = gfc_var_strlen(a);
+ len_b = gfc_var_strlen(b);
+
+ if (len_a == -1 || len_b == -1 || len_a == len_b)
return SUCCESS;
-
- if (b->ts.u.cl && b->ts.u.cl->length
- && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
- len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
- else if (b->expr_type == EXPR_CONSTANT
- && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
- len_b = b->value.character.length;
else
- return SUCCESS;
-
- if (len_a == len_b)
- return SUCCESS;
-
- gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
- len_a, len_b, name, &a->where);
- return FAILURE;
+ {
+ gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+ len_a, len_b, name, &a->where);
+ return FAILURE;
+ }
}