This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [gfortran, PR33254] Add -fbounds-checking for character array constructors
Tobias Schlüter wrote:
Dominique Dhumieres wrote:
catches the error, but if I put y(1:len(trim(y))) as the first item,
it does not:
[karma] f90/bug% diff bounds_check_10_db_1.f90 bounds_check_10_db.f90
12c12
< z = [trim(x), y(1:len(trim(y))), y(1:len(trim(x)))] ! should catch
first error
---
z = [y(1:len(trim(y))), trim(x), y(1:len(trim(x)))] ! should catch
first error
[karma] f90/bug% gfc -fbounds-check bounds_check_10_db.f90
[karma] f90/bug% a.out
[karma] f90/bug%
Am I alone to see that? If not, any idea about the reason?
It's really weird. In the case where it doesn't work the bounds-checks
simply don't appear in the .original dump.
I'll investigate.
I solved that problem. Unfortunately, while putting together a testcase
to exercise all possibilities of putting together a character
constructor, I ran into at least two new bugs.
I'm attaching a work-in-progress patch which fixes the issue Dominique
reported (bounds_check_11.f90) but fails a new testcase
(char_array_constructor_4.f90. If you remove the LEN(TRIM(x)) stuff it
doesn't ice but evaluates the string length twice, so there really are
two bugs.
I don't think that I'll have time for this during the week, so please be
patient. Or solve it yourself :-)
Cheers,
- Tobi
diff -r d7f02f5202f0 gcc/fortran/trans-array.c
--- a/gcc/fortran/trans-array.c Sun Oct 14 10:07:07 2007 +0000
+++ b/gcc/fortran/trans-array.c Sun Oct 14 22:14:49 2007 +0200
@@ -1310,11 +1310,14 @@ gfc_trans_array_constructor_value (stmtb
}
+static void
+get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len);
+
/* Figure out the string length of a variable reference expression.
Used by get_array_ctor_strlen. */
static void
-get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
+get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
{
gfc_ref *ref;
gfc_typespec *ts;
@@ -1339,9 +1342,15 @@ get_array_ctor_var_strlen (gfc_expr * ex
break;
case REF_SUBSTRING:
+ /* TODO: Substrings are tricky because we can't evaluate the
+ expression more than once. For now we just give up, and hope
+ we can figure it out elsewhere. */
if (ref->u.ss.start->expr_type != EXPR_CONSTANT
|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
- break;
+ {
+ get_array_ctor_all_strlen (block, expr, len);
+ return;
+ }
mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
@@ -1352,10 +1361,7 @@ get_array_ctor_var_strlen (gfc_expr * ex
return;
default:
- /* TODO: Substrings are tricky because we can't evaluate the
- expression more than once. For now we just give up, and hope
- we can figure it out elsewhere. */
- return;
+ gcc_unreachable ();
}
}
@@ -1410,63 +1416,72 @@ get_array_ctor_all_strlen (stmtblock_t *
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * plen)
{
bool is_const;
tree first_len = NULL_TREE;
+ tree len;
is_const = TRUE;
if (c == NULL)
{
- *len = build_int_cstu (gfc_charlen_type_node, 0);
+ *plen = build_int_cstu (gfc_charlen_type_node, 0);
return is_const;
}
for (; c; c = c->next)
{
+ len = NULL_TREE;
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
- if (!(*len && INTEGER_CST_P (*len)))
- *len = build_int_cstu (gfc_charlen_type_node,
- c->expr->value.character.length);
+ len = build_int_cstu (gfc_charlen_type_node,
+ c->expr->value.character.length);
break;
case EXPR_ARRAY:
- if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
+ if (!get_array_ctor_strlen (block, c->expr->value.constructor,
+ &len))
is_const = false;
break;
case EXPR_VARIABLE:
is_const = false;
- get_array_ctor_var_strlen (c->expr, len);
+ get_array_ctor_var_strlen (block, c->expr, &len);
break;
default:
is_const = false;
- get_array_ctor_all_strlen (block, c->expr, len);
+ get_array_ctor_all_strlen (block, c->expr, &len);
break;
}
+
if (flag_bounds_check)
{
+ /*debug_tree (*len);*/
if (!first_len)
- first_len = *len;
+ {
+ /*puts ("first");*/
+ first_len = len;
+ }
else
{
/* Verify that all constructor elements are of the same
length. */
tree cond = fold_build2 (NE_EXPR, boolean_type_node,
- first_len, *len);
+ first_len, len);
+
gfc_trans_runtime_check
(cond, block, &c->expr->where,
"Different CHARACTER lengths (%ld/%ld) in array constructor",
fold_convert (long_integer_type_node, first_len),
- fold_convert (long_integer_type_node, *len));
+ fold_convert (long_integer_type_node, len));
}
}
}
+ *plen = len;
return is_const;
}
diff -r d7f02f5202f0 gcc/testsuite/gfortran.dg/bounds_check_12.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/gfortran.dg/bounds_check_12.f90 Sun Oct 14 22:14:49 2007 +0200
@@ -0,0 +1,16 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Different CHARACTER lengths" }
+program array_char
+implicit none
+character (len=2) :: x
+character (len=2) :: y
+character (len=2) :: z(3)
+x = "a "
+y = "cd"
+z = trim(x)
+z = [y(1:len(trim(x))), y(1:1), x(1:len(trim(x)))] ! should work
+z = [ y(1:len(trim(y))), trim(x), y(1:len(trim(x)))] ! should catch first error
+end program array_char
+
+! { dg-output "Different CHARACTER lengths .2/1. in array constructor" }
diff -r d7f02f5202f0 gcc/testsuite/gfortran.dg/char_array_constructor_4.f90
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/gfortran.dg/char_array_constructor_4.f90 Sun Oct 14 22:14:49 2007 +0200
@@ -0,0 +1,63 @@
+! { dg-do run }
+! Covering most (all?) codepaths in CHARACTER array constructors
+CHARACTER*5 x, y(3)
+CHARACTER*5 z(5)
+
+type t
+ CHARACTER*5 c
+end type t
+
+type(t) a, b(2)
+
+integer :: count
+
+x = "12345"
+
+z = (/ x(:), (/ (x, i=1,3) /), x /)
+if (any (z /= "12345")) then; print *, z; call abort; endif
+
+a%c = x
+b(:)%c = x
+z(1:5) = (/ z(3), z(2)(1:len(x)), a%c, a%c(1:5), b(1:1)%c(1:len(trim(x))) /)
+if (any (z /= "12345")) then; print *, z; call abort; endif
+
+count = 0
+y = (/ "12345"(1:3), "01234"(2:4), "-0123"(3:call_once()) /)
+if (any (y /= "123 ")) then; print *, y; call abort; endif
+
+y = (/ f(z(2)) /)
+if (any (y /= "12345")) then; print *, y; call abort; endif
+
+call more_tests(x, y, z)
+
+contains
+ function f(x)
+ character*5 :: x, f(3)
+ f= (/ "12345", x, x(1:5) /)
+ end function f
+
+ integer function call_once()
+ if (count == 1) then; print *, "absurdistan"; call abort; end if
+ count = count + 1
+ call_once = 5
+ end function call_once
+
+ subroutine more_tests(x, y, z)
+ character(len=*) :: x, y(:), z(5)
+
+ z = (/ x(:), (/ (x, i=1,3) /), x /)
+ if (any (z /= "12345")) then; print *, z; call abort; endif
+
+ a%c = x
+ b(:)%c = x
+ z(1:5) = (/ z(3), z(2)(1:len(x)), a%c, a%c(1:5), b(1:1)%c(1:len(trim(x))) /)
+ if (any (z /= "12345")) then; print *, y; call abort; endif
+
+ count = 0
+ y = (/ "12345"(1:3), "01234"(2:4), "-0123"(3:call_once()) /)
+ if (any (y /= "123 ")) then; print *, y; call abort; endif
+
+ y = (/ f(z(2)) /)
+ if (any (y /= "12345")) then; print *, y; call abort; endif
+ end subroutine more_tests
+end