From: Daniel Franke Date: Thu, 4 Jun 2009 21:52:32 +0000 (-0400) Subject: re PR fortran/37203 (Check ORDER= of RESHAPE) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=535ff342b76110501c8673df1ae44db5e6ea55b4;p=gcc.git re PR fortran/37203 (Check ORDER= of RESHAPE) gcc/fortran/ 2009-06-04 Daniel Franke PR fortran/37203 * check.c (gfc_check_reshape): Additional checks for the SHAPE and ORDER arguments. * simplify.c (gfc_simplify_reshape): Converted argument checks to asserts. gcc/testsuite/ 2009-06-04 Daniel Franke PR fortran/37203 * gfortran.dg/reshape_order_5.f90: New. * gfortran.dg/reshape_shape_1.f90: New. From-SVN: r148190 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 19c415a0744..c93aa12861c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-06-04 Daniel Franke + + PR fortran/37203 + * check.c (gfc_check_reshape): Additional checks for the + SHAPE and ORDER arguments. + * simplify.c (gfc_simplify_reshape): Converted argument checks + to asserts. + 2009-06-03 Tobias Burnus * gfortran.texi: Add mixed-language programming, mention diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index db29264e9a6..c4e33bb88a4 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2324,7 +2324,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { mpz_t size; mpz_t nelems; - int m; + int shape_size; if (array_check (source, 0) == FAILURE) return FAILURE; @@ -2342,26 +2342,121 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, return FAILURE; } - m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS); + shape_size = mpz_get_ui (size); mpz_clear (size); - if (m > 0) + if (shape_size <= 0) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L is empty", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &shape->where); + return FAILURE; + } + else if (shape_size > GFC_MAX_DIMENSIONS) { gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more " "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); return FAILURE; } + else if (shape->expr_type == EXPR_ARRAY) + { + gfc_expr *e; + int i, extent; + for (i = 0; i < shape_size; ++i) + { + e = gfc_get_array_element (shape, i); + if (e->expr_type != EXPR_CONSTANT) + { + gfc_free_expr (e); + continue; + } + + gfc_extract_int (e, &extent); + if (extent < 0) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L has " + "negative element (%d)", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &e->where, extent); + return FAILURE; + } + + gfc_free_expr (e); + } + } if (pad != NULL) { if (same_type_check (source, 0, pad, 2) == FAILURE) return FAILURE; + if (array_check (pad, 2) == FAILURE) return FAILURE; } - if (order != NULL && array_check (order, 3) == FAILURE) - return FAILURE; + if (order != NULL) + { + if (array_check (order, 3) == FAILURE) + return FAILURE; + + if (type_check (order, 3, BT_INTEGER) == FAILURE) + return FAILURE; + + if (order->expr_type == EXPR_ARRAY) + { + int i, order_size, dim, perm[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + + for (i = 0; i < GFC_MAX_DIMENSIONS; ++i) + perm[i] = 0; + + gfc_array_size (order, &size); + order_size = mpz_get_ui (size); + mpz_clear (size); + + if (order_size != shape_size) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "has wrong number of elements (%d/%d)", + gfc_current_intrinsic_arg[3], + gfc_current_intrinsic, &order->where, + order_size, shape_size); + return FAILURE; + } + + for (i = 1; i <= order_size; ++i) + { + e = gfc_get_array_element (order, i-1); + if (e->expr_type != EXPR_CONSTANT) + { + gfc_free_expr (e); + continue; + } + + gfc_extract_int (e, &dim); + + if (dim < 1 || dim > order_size) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "has out-of-range dimension (%d)", + gfc_current_intrinsic_arg[3], + gfc_current_intrinsic, &e->where, dim); + return FAILURE; + } + + if (perm[dim-1] != 0) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L has " + "invalid permutation of dimensions (dimension " + "'%d' duplicated)", gfc_current_intrinsic_arg[3], + gfc_current_intrinsic, &e->where, dim); + return FAILURE; + } + + perm[dim-1] = 1; + gfc_free_expr (e); + } + } + } if (pad == NULL && shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 51a3c5198e5..98df0edd958 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3657,16 +3657,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, gfc_expr *e; /* Check that argument expression types are OK. */ - if (!is_constant_array_expr (source)) - return NULL; - - if (!is_constant_array_expr (shape_exp)) - return NULL; - - if (!is_constant_array_expr (pad)) - return NULL; - - if (!is_constant_array_expr (order_exp)) + if (!is_constant_array_expr (source) + || !is_constant_array_expr (shape_exp) + || !is_constant_array_expr (pad) + || !is_constant_array_expr (order_exp)) return NULL; /* Proceed with simplification, unpacking the array. */ @@ -3681,40 +3675,16 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, if (e == NULL) break; - if (gfc_extract_int (e, &shape[rank]) != NULL) - { - gfc_error ("Integer too large in shape specification at %L", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + gfc_extract_int (e, &shape[rank]); - if (rank >= GFC_MAX_DIMENSIONS) - { - gfc_error ("Too many dimensions in shape specification for RESHAPE " - "at %L", &e->where); - gfc_free_expr (e); - goto bad_reshape; - } - - if (shape[rank] < 0) - { - gfc_error ("Shape specification at %L cannot be negative", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); + gcc_assert (shape[rank] >= 0); gfc_free_expr (e); rank++; } - if (rank == 0) - { - gfc_error ("Shape specification at %L cannot be the null array", - &shape_exp->where); - goto bad_reshape; - } + gcc_assert (rank > 0); /* Now unpack the order array if present. */ if (order_exp == NULL) @@ -3730,41 +3700,14 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) { e = gfc_get_array_element (order_exp, i); - if (e == NULL) - { - gfc_error ("ORDER parameter of RESHAPE at %L is not the same " - "size as SHAPE parameter", &order_exp->where); - goto bad_reshape; - } - - if (gfc_extract_int (e, &order[i]) != NULL) - { - gfc_error ("Error in ORDER parameter of RESHAPE at %L", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } - - if (order[i] < 1 || order[i] > rank) - { - gfc_error ("ORDER parameter of RESHAPE at %L is out of range", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } - - order[i]--; - - if (x[order[i]]) - { - gfc_error ("Invalid permutation in ORDER parameter at %L", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + gcc_assert (e); + gfc_extract_int (e, &order[i]); gfc_free_expr (e); + gcc_assert (order[i] >= 1 && order[i] <= rank); + order[i]--; + gcc_assert (x[order[i]] == 0); x[order[i]] = 1; } } @@ -3812,18 +3755,13 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, e = gfc_get_array_element (source, j); else { - j = j - nsource; - - if (npad == 0) - { - gfc_error ("PAD parameter required for short SOURCE parameter " - "at %L", &source->where); - goto bad_reshape; - } + gcc_assert (npad > 0); + j = j - nsource; j = j % npad; e = gfc_get_array_element (pad, j); } + gcc_assert (e); if (head == NULL) head = tail = gfc_get_constructor (); @@ -3833,9 +3771,6 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, tail = tail->next; } - if (e == NULL) - goto bad_reshape; - tail->where = e->where; tail->expr = e; @@ -3867,11 +3802,6 @@ inc: e->rank = rank; return e; - -bad_reshape: - gfc_free_constructor (head); - mpz_clear (index); - return &gfc_bad_expr; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1cd5dc76c8d..7f4aa6b3b3a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-06-04 Daniel Franke + + PR fortran/37203 + * gfortran.dg/reshape_order_5.f90: New. + * gfortran.dg/reshape_shape_1.f90: New. + 2009-06-04 Jason Merrill * g++.dg/template/error38.C: Add pointer-to-typedef case. diff --git a/gcc/testsuite/gfortran.dg/reshape_order_5.f90 b/gcc/testsuite/gfortran.dg/reshape_order_5.f90 new file mode 100644 index 00000000000..9c76b88839f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reshape_order_5.f90 @@ -0,0 +1,16 @@ +! { dg-do "compile" } +! +! PR fortran/37203 - check RESHAPE arguments +! + + integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: shape1 = (/ 2, 5/) + integer, dimension(2) :: pad1 = (/ 0, 0/) + integer, dimension(2) :: t(2,5) + + t = reshape(source1, shape1, pad1, (/2, 1/)) ! ok + t = reshape(source1, shape1, pad1, (/2.1, 1.2/)) ! { dg-error "must be INTEGER" } + t = reshape(source1, shape1, pad1, (/2, 2/)) ! { dg-error "invalid permutation" } + t = reshape(source1, shape1, pad1, (/2, 3/)) ! { dg-error "out-of-range dimension" } + t = reshape(source1, shape1, pad1, (/2/)) ! { dg-error "wrong number of elements" } +end diff --git a/gcc/testsuite/gfortran.dg/reshape_shape_1.f90 b/gcc/testsuite/gfortran.dg/reshape_shape_1.f90 new file mode 100644 index 00000000000..008c9a8e5c1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reshape_shape_1.f90 @@ -0,0 +1,14 @@ +! { dg-do "compile" } +! +! PR fortran/37203 - check RESHAPE arguments +! + + integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: pad1 = (/ 0, 0/) + integer, dimension(2) :: t(2,5) + integer :: i + + t = reshape(source1, SHAPE(0), pad1, (/2, 1/)) ! { dg-error "is empty" } + t = reshape(source1, (/(i,i=1,32)/), pad1, (/2, 1/)) ! { dg-error "has more than" } + t = reshape(source1, (/ 2, -5/), pad1, (/2, 1/)) ! { dg-error "negative element" } +end