From 2220652d3f79f773fb25b4d21ea4cbf4406d1df2 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Fri, 5 Jan 2007 14:45:20 +0000
Subject: re PR fortran/23232 ([4.1 only] DATA implied DO variables)
2007-01-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/23232
* decl.c (gfc_in_match_data, gfc_set_in_match_data): New
functions to signal that a DATA statement is being matched.
(gfc_match_data): Call gfc_set_in_match_data on entry and on
exit.
* gfortran.h : Add prototypes for above.
* expr.c (check_init_expr): Avoid check on parameter or
variable if gfc_in_match_data is true.
(gfc_match_init_expr): Do not call error on non-reduction of
expression if gfc_in_match_data is true.
PR fortran/27996
PR fortran/27998
* decl.c (gfc_set_constant_character_len): Add boolean arg to
flag array constructor resolution. Warn if string is being
truncated. Standard dependent error if string is padded. Set
new arg to false for all three calls to
gfc_set_constant_character_len.
* match.h : Add boolean arg to prototype for
gfc_set_constant_character_len.
* gfortran.h : Add warn_character_truncation to gfc_options.
* options.c (set_Wall): Set warn_character_truncation if -Wall
is set.
* resolve.c (resolve_code): Warn if rhs string in character
assignment has to be truncated.
* array.c (gfc_resolve_character_array_constructor): Set new
argument to true for call to gfc_set_constant_character_len.
2007-01-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/23232
* gfortran.dg/data_implied_do_1.f90: New test.
PR fortran/27996
PR fortran/27998
* gfortran.dg/char_length_1.f90: New test.
From-SVN: r120485
---
gcc/fortran/resolve.c | 91 +++++++++++++++++++++++++++++++++++++++++----------
1 file changed, 73 insertions(+), 18 deletions(-)
(limited to 'gcc/fortran/resolve.c')
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3c28d45..44236e5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5084,6 +5084,28 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
goto call;
}
+ if (code->expr->ts.type == BT_CHARACTER
+ && gfc_option.warn_character_truncation)
+ {
+ int llen = 0, rlen = 0;
+ gfc_symbol *sym;
+ sym = code->expr->symtree->n.sym;
+ if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ llen = mpz_get_si (sym->ts.cl->length->value.integer);
+
+ if (code->expr2->expr_type == EXPR_CONSTANT)
+ rlen = code->expr2->value.character.length;
+
+ else if (code->expr2->ts.cl != NULL
+ && code->expr2->ts.cl->length != NULL
+ && code->expr2->ts.cl->length->expr_type == EXPR_CONSTANT)
+ rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
+
+ if (rlen && llen && rlen > llen)
+ gfc_warning_now ("rhs of CHARACTER assignment at %L will "
+ "be truncated (%d/%d)", &code->loc, rlen, llen);
+ }
+
if (gfc_pure (NULL))
{
if (gfc_impure_variable (code->expr->symtree->n.sym))
@@ -6435,17 +6457,47 @@ traverse_data_list (gfc_data_variable * var, locus * where)
{
mpz_t trip;
iterator_stack frame;
- gfc_expr *e;
+ gfc_expr *e, *start, *end, *step;
+ try retval = SUCCESS;
mpz_init (frame.value);
- mpz_init_set (trip, var->iter.end->value.integer);
- mpz_sub (trip, trip, var->iter.start->value.integer);
- mpz_add (trip, trip, var->iter.step->value.integer);
+ start = gfc_copy_expr (var->iter.start);
+ end = gfc_copy_expr (var->iter.end);
+ step = gfc_copy_expr (var->iter.step);
+
+ if (gfc_simplify_expr (start, 1) == FAILURE
+ || start->expr_type != EXPR_CONSTANT)
+ {
+ 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 ("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 ("iterator step at %L does not simplify",
+ &step->where);
+ retval = FAILURE;
+ goto cleanup;
+ }
+
+ mpz_init_set (trip, end->value.integer);
+ mpz_sub (trip, trip, start->value.integer);
+ mpz_add (trip, trip, step->value.integer);
- mpz_div (trip, trip, var->iter.step->value.integer);
+ mpz_div (trip, trip, step->value.integer);
- mpz_set (frame.value, var->iter.start->value.integer);
+ mpz_set (frame.value, start->value.integer);
frame.prev = iter_stack;
frame.variable = var->iter.var->symtree;
@@ -6456,26 +6508,34 @@ traverse_data_list (gfc_data_variable * var, locus * where)
if (traverse_data_var (var->list, where) == FAILURE)
{
mpz_clear (trip);
- return FAILURE;
+ retval = FAILURE;
+ goto cleanup;
}
e = gfc_copy_expr (var->expr);
if (gfc_simplify_expr (e, 1) == FAILURE)
- {
- gfc_free_expr (e);
- return FAILURE;
- }
+ {
+ gfc_free_expr (e);
+ mpz_clear (trip);
+ retval = FAILURE;
+ goto cleanup;
+ }
- mpz_add (frame.value, frame.value, var->iter.step->value.integer);
+ mpz_add (frame.value, frame.value, step->value.integer);
mpz_sub_ui (trip, trip, 1);
}
mpz_clear (trip);
+cleanup:
mpz_clear (frame.value);
+ gfc_free_expr (start);
+ gfc_free_expr (end);
+ gfc_free_expr (step);
+
iter_stack = frame.prev;
- return SUCCESS;
+ return retval;
}
@@ -6520,11 +6580,6 @@ resolve_data_variables (gfc_data_variable * d)
if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
return FAILURE;
- if (d->iter.start->expr_type != EXPR_CONSTANT
- || d->iter.end->expr_type != EXPR_CONSTANT
- || d->iter.step->expr_type != EXPR_CONSTANT)
- gfc_internal_error ("resolve_data_variables(): Bad iterator");
-
if (resolve_data_variables (d->list) == FAILURE)
return FAILURE;
}
--
cgit v1.1