Hello world,
the attached patch enables more sophisticated bounds-checking on
array slices by using gfc_dep_difference to calculate extents.
The information may also be useful in other places of the
front end, I don't really know.
There is one wrinkle (alluded to in the comments) which makes
this harder. When somebody changes the value of a variable
used in detemining the size of an array, such as
subroutine foo(a,n)
real, dimension(n) :: a
n = n -2
print *,ubound(a(n-1:))
we cannot compare n-1 against n and think that their difference is
one :-(
This is why I restricted myself to expressions where all
indices are specified, e.g. in a(n+1:n+4) or none are specified,
as in a(:).
In order for this to work on 64-bit systems, it was necessary
to look through widening integer conversions, so I added that
functionality to discard_nops. Using this function in
gfc_dep_compare_expr made this function shorter and cleaner.
Regression-tested. OK for trunk?
Thomas
2013-08-14 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/58146
* array.c (gfc_ref_dimen_size): If possible, use
gfc_dep_difference to calculate array refrence
sizes. Fall back to integer code otherwise.
* dependency.c (discard_nops). Move up.
Also discarde widening integer conversions.
(gfc_dep_compare_expr): Use discard_nops.
2013-08-14 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/58146
* gfortran.dg/bounds_check_18.f90: New test.
Index: array.c
===================================================================
--- array.c (Revision 201648)
+++ array.c (Arbeitskopie)
@@ -2112,6 +2112,7 @@ bool
gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
{
mpz_t upper, lower, stride;
+ mpz_t diff;
bool t;
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
@@ -2130,9 +2131,63 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen,
break;
case DIMEN_RANGE:
+
+ mpz_init (stride);
+
+ if (ar->stride[dimen] == NULL)
+ mpz_set_ui (stride, 1);
+ else
+ {
+ if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
+ {
+ mpz_clear (stride);
+ return false;
+ }
+ mpz_set (stride, ar->stride[dimen]->value.integer);
+ }
+
+ /* Calculate the number of elements via gfc_dep_differce, but only if
+ start and end are both supplied in the reference or the array spec.
+ This is to guard against strange but valid code like
+
+ subroutine foo(a,n)
+ real a(1:n)
+ n = 3
+ print *,size(a(n-1:))
+
+ where the user changes the value of a variable. If we have to
+ determine end as well, we cannot do this using gfc_dep_difference.
+ Fall back to the constants-only code then. */
+
+ if (end == NULL)
+ {
+ bool use_dep;
+
+ use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
+ &diff);
+ if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
+ use_dep = gfc_dep_difference (ar->as->upper[dimen],
+ ar->as->lower[dimen], &diff);
+
+ if (use_dep)
+ {
+ mpz_init (*result);
+ mpz_add (*result, diff, stride);
+ mpz_div (*result, *result, stride);
+ if (mpz_cmp_ui (*result, 0) < 0)
+ mpz_set_ui (*result, 0);
+
+ mpz_clear (stride);
+ mpz_clear (diff);
+ return true;
+ }
+
+ }
+
+ /* Constant-only code here, which covers more cases
+ like a(:4) etc. */
mpz_init (upper);
mpz_init (lower);
- mpz_init (stride);
t = false;
if (ar->start[dimen] == NULL)
@@ -2163,15 +2218,6 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen,
mpz_set (upper, ar->end[dimen]->value.integer);
}
- if (ar->stride[dimen] == NULL)
- mpz_set_ui (stride, 1);
- else
- {
- if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
- goto cleanup;
- mpz_set (stride, ar->stride[dimen]->value.integer);
- }
-
mpz_init (*result);
mpz_sub (*result, upper, lower);
mpz_add (*result, *result, stride);
Index: dependency.c
===================================================================
--- dependency.c (Revision 201648)
+++ dependency.c (Arbeitskopie)
@@ -240,6 +240,46 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr
return -2;
}
+/* Helper function to look through parens, unary plus and widening
+ integer conversions. */
+
+static gfc_expr*
+discard_nops (gfc_expr *e)
+{
+ gfc_actual_arglist *arglist;
+
+ if (e == NULL)
+ return NULL;
+
+ while (true)
+ {
+ if (e->expr_type == EXPR_OP
+ && (e->value.op.op == INTRINSIC_UPLUS
+ || e->value.op.op == INTRINSIC_PARENTHESES))
+ {
+ e = e->value.op.op1;
+ continue;
+ }
+
+ if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
+ && e->value.function.isym->id == GFC_ISYM_CONVERSION
+ && e->ts.type == BT_INTEGER)
+ {
+ arglist = e->value.function.actual;
+ if (arglist->expr->ts.type == BT_INTEGER
+ && e->ts.kind > arglist->expr->ts.kind)
+ {
+ e = arglist->expr;
+ continue;
+ }
+ }
+ break;
+ }
+
+ return e;
+}
+
+
/* Compare two expressions. Return values:
* +1 if e1 > e2
* 0 if e1 == e2
@@ -255,57 +295,13 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
gfc_actual_arglist *args1;
gfc_actual_arglist *args2;
int i;
- gfc_expr *n1, *n2;
- n1 = NULL;
- n2 = NULL;
-
if (e1 == NULL && e2 == NULL)
return 0;
- /* Remove any integer conversion functions to larger types. */
- if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
- && e1->value.function.isym->id == GFC_ISYM_CONVERSION
- && e1->ts.type == BT_INTEGER)
- {
- args1 = e1->value.function.actual;
- if (args1->expr->ts.type == BT_INTEGER
- && e1->ts.kind > args1->expr->ts.kind)
- n1 = args1->expr;
- }
+ e1 = discard_nops (e1);
+ e2 = discard_nops (e2);
- if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
- && e2->value.function.isym->id == GFC_ISYM_CONVERSION
- && e2->ts.type == BT_INTEGER)
- {
- args2 = e2->value.function.actual;
- if (args2->expr->ts.type == BT_INTEGER
- && e2->ts.kind > args2->expr->ts.kind)
- n2 = args2->expr;
- }
-
- if (n1 != NULL)
- {
- if (n2 != NULL)
- return gfc_dep_compare_expr (n1, n2);
- else
- return gfc_dep_compare_expr (n1, e2);
- }
- else
- {
- if (n2 != NULL)
- return gfc_dep_compare_expr (e1, n2);
- }
-
- if (e1->expr_type == EXPR_OP
- && (e1->value.op.op == INTRINSIC_UPLUS
- || e1->value.op.op == INTRINSIC_PARENTHESES))
- return gfc_dep_compare_expr (e1->value.op.op1, e2);
- if (e2->expr_type == EXPR_OP
- && (e2->value.op.op == INTRINSIC_UPLUS
- || e2->value.op.op == INTRINSIC_PARENTHESES))
- return gfc_dep_compare_expr (e1, e2->value.op.op1);
-
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
/* Compare X+C vs. X, for INTEGER only. */
@@ -501,21 +497,6 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
}
-/* Helper function to look through parens and unary plus. */
-
-static gfc_expr*
-discard_nops (gfc_expr *e)
-{
-
- while (e && e->expr_type == EXPR_OP
- && (e->value.op.op == INTRINSIC_UPLUS
- || e->value.op.op == INTRINSIC_PARENTHESES))
- e = e->value.op.op1;
-
- return e;
-}
-
-
/* Return the difference between two expressions. Integer expressions of
the form
! { dg-do compile }
program main
implicit none
integer :: n
real, dimension(10) :: a
n = 0
call random_number(a)
if (any(a(n+1:n+5) > [1.0, 2.0, 3.0])) print *,"Hello!" ! { dg-error "not conformable" }
end program main
