From: Harald Anlauf Date: Fri, 26 Nov 2021 20:00:35 +0000 (+0100) Subject: Fortran: improve check of arguments to the RESHAPE intrinsic X-Git-Tag: basepoints/gcc-13~2763 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=4d540c7a4a7fb87b04d06e1ee7f9b004116279a4;p=thirdparty%2Fgcc.git Fortran: improve check of arguments to the RESHAPE intrinsic gcc/fortran/ChangeLog: PR fortran/103411 * check.c (gfc_check_reshape): Improve check of size of source array for the RESHAPE intrinsic against the given shape when pad is not given, and shape is a parameter. Try other simplifications of shape. gcc/testsuite/ChangeLog: PR fortran/103411 * gfortran.dg/pr68153.f90: Adjust test to improved check. * gfortran.dg/reshape_7.f90: Likewise. * gfortran.dg/reshape_9.f90: New test. --- diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 5a5aca10ebe1..3e65f3d8b1f8 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -4699,6 +4699,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, mpz_t size; mpz_t nelems; int shape_size; + bool shape_is_const; if (!array_check (source, 0)) return false; @@ -4732,7 +4733,11 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); return false; } - else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape)) + + gfc_simplify_expr (shape, 0); + shape_is_const = gfc_is_constant_expr (shape); + + if (shape->expr_type == EXPR_ARRAY && shape_is_const) { gfc_expr *e; int i, extent; @@ -4748,38 +4753,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_error ("%qs argument of %qs intrinsic at %L has " "negative element (%d)", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &e->where, extent); - return false; - } - } - } - else if (shape->expr_type == EXPR_VARIABLE && shape->ref - && shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1 - && shape->ref->u.ar.as - && shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT - && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER - && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT - && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER - && shape->symtree->n.sym->attr.flavor == FL_PARAMETER - && shape->symtree->n.sym->value) - { - int i, extent; - gfc_expr *e, *v; - - v = shape->symtree->n.sym->value; - - for (i = 0; i < shape_size; i++) - { - e = gfc_constructor_lookup_expr (v->value.constructor, i); - if (e == NULL) - break; - - gfc_extract_int (e, &extent); - - if (extent < 0) - { - gfc_error ("Element %d of actual argument of RESHAPE at %L " - "cannot be negative", i + 1, &shape->where); + gfc_current_intrinsic, &shape->where, extent); return false; } } @@ -4856,8 +4830,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, } } - if (pad == NULL && shape->expr_type == EXPR_ARRAY - && gfc_is_constant_expr (shape) + if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE)) { diff --git a/gcc/testsuite/gfortran.dg/pr68153.f90 b/gcc/testsuite/gfortran.dg/pr68153.f90 index 1a360f80cd62..46a3bc029d71 100644 --- a/gcc/testsuite/gfortran.dg/pr68153.f90 +++ b/gcc/testsuite/gfortran.dg/pr68153.f90 @@ -5,5 +5,5 @@ ! program foo integer, parameter :: a(2) = [2, -2] - integer, parameter :: b(2,2) = reshape([1, 2, 3, 4], a) ! { dg-error "cannot be negative" } + integer, parameter :: b(2,2) = reshape([1, 2, 3, 4], a) ! { dg-error "negative" } end program foo diff --git a/gcc/testsuite/gfortran.dg/reshape_7.f90 b/gcc/testsuite/gfortran.dg/reshape_7.f90 index d752650aa4ec..4216cb60cbb2 100644 --- a/gcc/testsuite/gfortran.dg/reshape_7.f90 +++ b/gcc/testsuite/gfortran.dg/reshape_7.f90 @@ -4,7 +4,7 @@ subroutine p0 integer, parameter :: sh(2) = [2, 3] integer, parameter :: & - & a(2,2) = reshape([1, 2, 3, 4], sh) ! { dg-error "Different shape" } + & a(2,2) = reshape([1, 2, 3, 4], sh) ! { dg-error "not enough elements" } if (a(1,1) /= 0) STOP 1 end subroutine p0 diff --git a/gcc/testsuite/gfortran.dg/reshape_9.f90 b/gcc/testsuite/gfortran.dg/reshape_9.f90 new file mode 100644 index 000000000000..dc52e26cc86c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reshape_9.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/103411 - ICE in gfc_conv_array_initializer +! Based on testcase by G. Steinmetz +! Test simplifications for checks of shape argument to reshape intrinsic + +program p + integer :: i + integer, parameter :: a(2) = [2,2] + integer, parameter :: u(5) = [1,2,2,42,2] + integer, parameter :: v(1,3) = 2 + integer, parameter :: d(2,2) = reshape([1,2,3,4,5], a) + integer, parameter :: c(2,2) = reshape([1,2,3,4], a) + integer, parameter :: b(2,2) = & + reshape([1,2,3], a) ! { dg-error "not enough elements" } + print *, reshape([1,2,3], a) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], a) + print *, reshape([1,2,3,4,5], a) + print *, b, c, d + print *, reshape([1,2,3], [(u(i),i=1,2)]) + print *, reshape([1,2,3], [(u(i),i=2,3)]) ! { dg-error "not enough elements" } + print *, reshape([1,2,3], & + [(u(i)*(-1)**i,i=2,3)]) ! { dg-error "has negative element" } + print *, reshape([1,2,3,4], u(5:3:-2)) + print *, reshape([1,2,3], u(5:3:-2)) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], u([5,3])) + print *, reshape([1,2,3] , u([5,3])) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], v(1,2:)) + print *, reshape([1,2,3], v(1,2:)) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], v(1,[2,1])) + print *, reshape([1,2,3] , v(1,[2,1])) ! { dg-error "not enough elements" } +end