From 7ba8c18c1eb8ab48d44a9735c9974ae09b8dd9d4 Mon Sep 17 00:00:00 2001 From: Daniel Franke Date: Sat, 6 Jun 2009 14:51:29 -0400 Subject: [PATCH] re PR fortran/32890 (Compile-time detect of LHS/RHS missmatch for PACK) fortran/ 2009-06-06 Daniel Franke PR fortran/32890 * intrinsic.h (gfc_simplify_pack): New prototype. * intrinsic.c (add_functions): Added simplifier-callback to PACK. * simplify.c (is_constant_array_expr): Moved to beginning of file. (gfc_simplify_pack): New. * check.c (gfc_check_pack): Check that VECTOR has enough elements. Added safeguards for empty arrays. testsuite/ 2009-06-06 Daniel Franke PR fortran/32890 * gfortran.dg/pack_assign_1.f90: New. * gfortran.dg/pack_vector_1.f90: New. From-SVN: r148237 --- gcc/fortran/ChangeLog | 12 +++ gcc/fortran/check.c | 52 ++++++++++++- gcc/fortran/intrinsic.c | 2 +- gcc/fortran/intrinsic.h | 1 + gcc/fortran/simplify.c | 116 +++++++++++++++++++++++----- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/pack_assign_1.f90 | 8 ++ gcc/testsuite/gfortran.dg/pack_vector_1.f90 | 10 +++ 8 files changed, 184 insertions(+), 23 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pack_assign_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pack_vector_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5eacd0f..b50949f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2009-06-06 Daniel Franke + + PR fortran/32890 + * intrinsic.h (gfc_simplify_pack): New prototype. + * intrinsic.c (add_functions): Added + simplifier-callback to PACK. + * simplify.c (is_constant_array_expr): Moved + to beginning of file. + (gfc_simplify_pack): New. + * check.c (gfc_check_pack): Check that VECTOR has enough elements. + Added safeguards for empty arrays. + 2009-06-05 Kaveh R. Ghazi * simplify.c (call_mpc_func): Use mpc_realref/mpc_imagref diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index c4e33bb..b61909b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2149,13 +2149,63 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) if (vector != NULL) { + mpz_t array_size, vector_size; + bool have_array_size, have_vector_size; + if (same_type_check (array, 0, vector, 2) == FAILURE) return FAILURE; if (rank_check (vector, 2, 1) == FAILURE) return FAILURE; - /* TODO: More constraints here. */ + /* VECTOR requires at least as many elements as MASK + has .TRUE. values. */ + have_array_size = gfc_array_size (array, &array_size) == SUCCESS; + have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS; + + if (have_vector_size + && (mask->expr_type == EXPR_ARRAY + || (mask->expr_type == EXPR_CONSTANT + && have_array_size))) + { + int mask_true_values = 0; + + if (mask->expr_type == EXPR_ARRAY) + { + gfc_constructor *mask_ctor = mask->value.constructor; + while (mask_ctor) + { + if (mask_ctor->expr->expr_type != EXPR_CONSTANT) + { + mask_true_values = 0; + break; + } + + if (mask_ctor->expr->value.logical) + mask_true_values++; + + mask_ctor = mask_ctor->next; + } + } + else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) + mask_true_values = mpz_get_si (array_size); + + if (mpz_get_si (vector_size) < mask_true_values) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must " + "provide at least as many elements as there " + "are .TRUE. values in '%s' (%ld/%d)", + gfc_current_intrinsic_arg[2],gfc_current_intrinsic, + &vector->where, gfc_current_intrinsic_arg[1], + mpz_get_si (vector_size), mask_true_values); + return FAILURE; + } + } + + if (have_array_size) + mpz_clear (array_size); + if (have_vector_size) + mpz_clear (vector_size); } return SUCCESS; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 0b16a72..7744b33 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2209,7 +2209,7 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_pack, NULL, gfc_resolve_pack, + gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack, ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, v, BT_REAL, dr, OPTIONAL); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 7e8bc73..4a4aa5a 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -289,6 +289,7 @@ gfc_expr *gfc_simplify_null (gfc_expr *); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_precision (gfc_expr *); gfc_expr *gfc_simplify_radix (gfc_expr *); gfc_expr *gfc_simplify_range (gfc_expr *); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index fea1b91..09cf297 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -27,6 +27,10 @@ along with GCC; see the file COPYING3. If not see #include "intrinsic.h" #include "target-memory.h" +/* Savely advance an array constructor by 'n' elements. + Mainly used by simplifiers of transformational intrinsics. */ +#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0) + gfc_expr gfc_bad_expr; @@ -229,6 +233,28 @@ call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im, } #endif + +/* Test that the expression is an constant array. */ + +static bool +is_constant_array_expr (gfc_expr *e) +{ + gfc_constructor *c; + + if (e == NULL) + return true; + + if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) + return false; + + for (c = e->value.constructor; c; c = c->next) + if (c->expr->expr_type != EXPR_CONSTANT) + return false; + + return true; +} + + /********************** Simplification functions *****************************/ gfc_expr * @@ -3360,6 +3386,75 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y) gfc_expr * +gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) +{ + gfc_expr *result; + gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; + + if (!is_constant_array_expr(array) + || !is_constant_array_expr(vector) + || (!gfc_is_constant_expr (mask) + && !is_constant_array_expr(mask))) + return NULL; + + result = gfc_start_constructor (array->ts.type, + array->ts.kind, + &array->where); + + array_ctor = array->value.constructor; + vector_ctor = vector ? vector->value.constructor : NULL; + + if (mask->expr_type == EXPR_CONSTANT + && mask->value.logical) + { + /* Copy all elements of ARRAY to RESULT. */ + while (array_ctor) + { + gfc_append_constructor (result, + gfc_copy_expr (array_ctor->expr)); + + ADVANCE (array_ctor, 1); + ADVANCE (vector_ctor, 1); + } + } + else if (mask->expr_type == EXPR_ARRAY) + { + /* Copy only those elements of ARRAY to RESULT whose + MASK equals .TRUE.. */ + mask_ctor = mask->value.constructor; + while (mask_ctor) + { + if (mask_ctor->expr->value.logical) + { + gfc_append_constructor (result, + gfc_copy_expr (array_ctor->expr)); + ADVANCE (vector_ctor, 1); + } + + ADVANCE (array_ctor, 1); + ADVANCE (mask_ctor, 1); + } + } + + /* Append any left-over elements from VECTOR to RESULT. */ + while (vector_ctor) + { + gfc_append_constructor (result, + gfc_copy_expr (vector_ctor->expr)); + ADVANCE (vector_ctor, 1); + } + + result->shape = gfc_get_shape (1); + gfc_array_size (result, &result->shape[0]); + + if (array->ts.type == BT_CHARACTER) + result->ts.cl = array->ts.cl; + + return result; +} + + +gfc_expr * gfc_simplify_precision (gfc_expr *e) { gfc_expr *result; @@ -3621,27 +3716,6 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) } -/* Test that the expression is an constant array. */ - -static bool -is_constant_array_expr (gfc_expr *e) -{ - gfc_constructor *c; - - if (e == NULL) - return true; - - if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) - return false; - - for (c = e->value.constructor; c; c = c->next) - if (c->expr->expr_type != EXPR_CONSTANT) - return false; - - return true; -} - - /* This one is a bear, but mainly has to do with shuffling elements. */ gfc_expr * diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6c4b7ca..ca9f04f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-06-06 Daniel Franke + + PR fortran/32890 + * gfortran.dg/pack_assign_1.f90: New. + * gfortran.dg/pack_vector_1.f90: New. + 2009-06-05 Jakub Jelinek PR middle-end/40340 diff --git a/gcc/testsuite/gfortran.dg/pack_assign_1.f90 b/gcc/testsuite/gfortran.dg/pack_assign_1.f90 new file mode 100644 index 0000000..4bab0da --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pack_assign_1.f90 @@ -0,0 +1,8 @@ +! { dg-do "compile" } +! PR32890 - compile-time checks for assigments + +INTEGER :: it, neighbrs(42) ! anything but 30 + +neighbrs = PACK((/ (it, it=1,30) /), (/ (it, it=1,30) /) < 3, (/ (0,it=1,30) /) ) ! { dg-error "Different shape" } + +END diff --git a/gcc/testsuite/gfortran.dg/pack_vector_1.f90 b/gcc/testsuite/gfortran.dg/pack_vector_1.f90 new file mode 100644 index 0000000..ba3624e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pack_vector_1.f90 @@ -0,0 +1,10 @@ +! { dg-do "compile" } +! +! Check that the VECTOR argument of the PACK intrinsic has at least +! as many elements as the MASK has .TRUE. values. +! + + INTEGER :: res(2) + res = PACK ((/ 1, 2, 3 /), (/.TRUE., .TRUE., .FALSE. /), SHAPE(1)) !{ dg-error "must provide at least as many" } + res = PACK ((/ 1, 2, 3 /), (/.TRUE., .TRUE., .FALSE. /), (/ -1 /)) !{ dg-error "must provide at least as many" } +END -- 2.7.4