diff options
| author | Daniel Franke <franke.daniel@gmail.com> | 2009-06-06 14:51:29 -0400 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2009-06-06 20:51:29 +0200 |
| commit | 7ba8c18c1eb8ab48d44a9735c9974ae09b8dd9d4 (patch) | |
| tree | fd5f22b85c7834a1bd7f940233ff37789a1b2dc3 /gcc/fortran/check.c | |
| parent | dbb0ce047b0299395e1f7140ec6474cf402498ca (diff) | |
| download | gcc-7ba8c18c1eb8ab48d44a9735c9974ae09b8dd9d4.zip gcc-7ba8c18c1eb8ab48d44a9735c9974ae09b8dd9d4.tar.gz gcc-7ba8c18c1eb8ab48d44a9735c9974ae09b8dd9d4.tar.bz2 | |
re PR fortran/32890 (Compile-time detect of LHS/RHS missmatch for PACK)
fortran/
2009-06-06 Daniel Franke <franke.daniel@gmail.com>
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 <franke.daniel@gmail.com>
PR fortran/32890
* gfortran.dg/pack_assign_1.f90: New.
* gfortran.dg/pack_vector_1.f90: New.
From-SVN: r148237
Diffstat (limited to 'gcc/fortran/check.c')
| -rw-r--r-- | gcc/fortran/check.c | 52 |
1 files changed, 51 insertions, 1 deletions
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; |