aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog30
-rw-r--r--gcc/fortran/array.c2
-rw-r--r--gcc/fortran/decl.c39
-rw-r--r--gcc/fortran/expr.c6
-rw-r--r--gcc/fortran/gfortran.h5
-rw-r--r--gcc/fortran/match.h2
-rw-r--r--gcc/fortran/options.c1
-rw-r--r--gcc/fortran/resolve.c91
-rw-r--r--gcc/testsuite/ChangeLog9
-rw-r--r--gcc/testsuite/gfortran.dg/char_length_1.f9018
-rw-r--r--gcc/testsuite/gfortran.dg/data_implied_do_1.f9015
11 files changed, 193 insertions, 25 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index be3a9b5..0d9ade0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,33 @@
+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 Tobias Burnus <burnus@net-b.de>
PR fortran/29624
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 479e60b..d3606f5 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1587,7 +1587,7 @@ got_charlen:
/* Update the element constructors. */
for (p = expr->value.constructor; p; p = p->next)
if (p->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (max_length, p->expr);
+ gfc_set_constant_character_len (max_length, p->expr, true);
}
}
}
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d8988fd..b2f401f 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -74,6 +74,20 @@ gfc_symbol *gfc_new_block;
/********************* DATA statement subroutines *********************/
+static bool in_match_data = false;
+
+bool
+gfc_in_match_data (void)
+{
+ return in_match_data;
+}
+
+void
+gfc_set_in_match_data (bool set_value)
+{
+ in_match_data = set_value;
+}
+
/* Free a gfc_data_variable structure and everything beneath it. */
static void
@@ -455,6 +469,8 @@ gfc_match_data (void)
gfc_data *new;
match m;
+ gfc_set_in_match_data (true);
+
for (;;)
{
new = gfc_get_data ();
@@ -477,6 +493,8 @@ gfc_match_data (void)
gfc_match_char (','); /* Optional comma */
}
+ gfc_set_in_match_data (false);
+
if (gfc_pure (NULL))
{
gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
@@ -486,6 +504,7 @@ gfc_match_data (void)
return MATCH_YES;
cleanup:
+ gfc_set_in_match_data (false);
gfc_free_data (new);
return MATCH_ERROR;
}
@@ -743,7 +762,7 @@ build_sym (const char *name, gfc_charlen * cl,
truncated. */
void
-gfc_set_constant_character_len (int len, gfc_expr * expr)
+gfc_set_constant_character_len (int len, gfc_expr * expr, bool array)
{
char * s;
int slen;
@@ -758,6 +777,18 @@ gfc_set_constant_character_len (int len, gfc_expr * expr)
memcpy (s, expr->value.character.string, MIN (len, slen));
if (len > slen)
memset (&s[slen], ' ', len - slen);
+
+ if (gfc_option.warn_character_truncation && slen > len)
+ gfc_warning_now ("CHARACTER expression at %L is being truncated "
+ "(%d/%d)", &expr->where, slen, len);
+
+ /* Apply the standard by 'hand' otherwise it gets cleared for
+ initializers. */
+ if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
+ gfc_error_now ("The CHARACTER elements of the array constructor "
+ "at %L must have the same length (%d/%d)",
+ &expr->where, slen, len);
+
s[len] = '\0';
gfc_free (expr->value.character.string);
expr->value.character.string = s;
@@ -909,13 +940,13 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, init);
+ gfc_set_constant_character_len (len, init, false);
else if (init->expr_type == EXPR_ARRAY)
{
gfc_free_expr (init->ts.cl->length);
init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
for (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr);
+ gfc_set_constant_character_len (len, p->expr, false);
}
}
}
@@ -4025,7 +4056,7 @@ do_parm (void)
&& init->ts.type == BT_CHARACTER
&& init->ts.kind == 1)
gfc_set_constant_character_len (
- mpz_get_si (sym->ts.cl->length->value.integer), init);
+ mpz_get_si (sym->ts.cl->length->value.integer), init, false);
sym->value = init;
return MATCH_YES;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 7c2069c..1146bd1 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1829,6 +1829,9 @@ check_init_expr (gfc_expr * e)
break;
}
+ if (gfc_in_match_data ())
+ break;
+
gfc_error ("Parameter '%s' at %L has not been declared or is "
"a variable, which does not reduce to a constant "
"expression", e->symtree->n.sym->name, &e->where);
@@ -1912,7 +1915,8 @@ gfc_match_init_expr (gfc_expr ** result)
/* Not all inquiry functions are simplified to constant expressions
so it is necessary to call check_inquiry again. */
if (!gfc_is_constant_expr (expr)
- && check_inquiry (expr, 1) == FAILURE)
+ && check_inquiry (expr, 1) == FAILURE
+ && !gfc_in_match_data ())
{
gfc_error ("Initialization expression didn't reduce %C");
return MATCH_ERROR;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6286297..695d26d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1637,6 +1637,7 @@ typedef struct
int warn_surprising;
int warn_tabs;
int warn_underflow;
+ int warn_character_truncation;
int max_errors;
int flag_all_intrinsics;
@@ -1713,6 +1714,10 @@ void gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t);
void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
+/* decl.c */
+bool gfc_in_match_data (void);
+void gfc_set_in_match_data (bool);
+
/* scanner.c */
void gfc_scanner_done_1 (void);
void gfc_scanner_init_1 (void);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 2209c0d..3c8089a 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -130,7 +130,7 @@ match gfc_match_derived_decl (void);
match gfc_match_implicit_none (void);
match gfc_match_implicit (void);
-void gfc_set_constant_character_len (int, gfc_expr *);
+void gfc_set_constant_character_len (int, gfc_expr *, bool);
/* Matchers for attribute declarations */
match gfc_match_allocatable (void);
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 8819b60..da8db65 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -309,6 +309,7 @@ set_Wall (void)
gfc_option.warn_surprising = 1;
gfc_option.warn_tabs = 0;
gfc_option.warn_underflow = 1;
+ gfc_option.warn_character_truncation = 1;
set_Wunused (1);
warn_return_type = 1;
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;
}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3a5224a..49786c5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+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.
+
2007-01-05 Richard Guenther <rguenther@suse.de>
PR middle-end/28116
diff --git a/gcc/testsuite/gfortran.dg/char_length_1.f90 b/gcc/testsuite/gfortran.dg/char_length_1.f90
index e69de29..e372343 100644
--- a/gcc/testsuite/gfortran.dg/char_length_1.f90
+++ b/gcc/testsuite/gfortran.dg/char_length_1.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-Wall -std=f2003" }
+! Tests the patch for PR27996 and PR27998, in which warnings
+! or errors were not emitted when the length of character
+! constants was changed silently.
+!
+! Contributed by Tobias Burnus <tobias.burnus@physik.fu-berlin.de>
+!
+program test
+ character(10) :: a(3)
+ character(10) :: b(3)= &
+ (/ 'Takata ', 'Tanaka', 'Hayashi' /) ! { dg-error "same length" }
+ character(4) :: c = "abcde" ! { dg-warning "being truncated" }
+ a = (/ 'Takata', 'Tanaka ', 'Hayashi' /) ! { dg-error "same length" }
+ a = (/ 'Takata ', 'Tanaka ', 'Hayashi' /)
+ b = "abc"
+ c = "abcdefg" ! { dg-warning "will be truncated" }
+end program test
diff --git a/gcc/testsuite/gfortran.dg/data_implied_do_1.f90 b/gcc/testsuite/gfortran.dg/data_implied_do_1.f90
new file mode 100644
index 0000000..1cc977c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_implied_do_1.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! Test of the patch for PR23232, in which implied do loop
+! variables were not permitted in DATA statements.
+!
+! Contributed by Roger Ferrer Ibáñez <rofi@ya.com>
+!
+PROGRAM p
+ REAL :: TWO_ARRAY (3, 3)
+ INTEGER :: K, J
+ DATA ((TWO_ARRAY (K, J), K = 1, J-1), J = 1, 3) /3 * 1.0/
+ DATA ((TWO_ARRAY (K, J), K = J, 3), J = 1, 3) /6 * 2.0/
+ if (any (reshape (two_array, (/9/)) &
+ .ne. (/2.0,2.0,2.0,1.0,2.0,2.0,1.0,1.0,2.0/))) call abort ()
+END PROGRAM
+
generated by cgit v1.1 at 2025-03-24 20:00:52 +0000