diff options
author | domob <domob@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-07-28 17:06:40 +0000 |
---|---|---|
committer | domob <domob@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-07-28 17:06:40 +0000 |
commit | 9fe43b2b903d280b3b4f114c2856baa824c6eaca (patch) | |
tree | d6abc79640b3f8726b5ce5ea87b458be1a547ddc /gcc | |
parent | 2241e3a7d3449adac706d7a186ea72dc44bffd21 (diff) | |
download | gcc-9fe43b2b903d280b3b4f114c2856baa824c6eaca.tar.gz |
2010-07-28 Daniel Kraft <d@domob.eu>
* gfortran.h (gfc_build_intrinsic_call): New method.
* expr.c (gfc_build_intrinsic_call): New method.
* simplify.c (range_check): Ignore non-constant value.
(simplify_bound_dim): Handle non-variable expressions and
fix memory leak with non-free'ed expression.
(simplify_bound): Handle non-variable expressions.
(gfc_simplify_shape): Ditto.
(gfc_simplify_size): Ditto, but only in certain cases possible.
2010-07-28 Daniel Kraft <d@domob.eu>
* gfortran.dg/bound_8.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162648 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/ChangeLog | 11 | ||||
-rw-r--r-- | gcc/fortran/expr.c | 44 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 2 | ||||
-rw-r--r-- | gcc/fortran/simplify.c | 150 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/bound_8.f90 | 44 |
6 files changed, 229 insertions, 26 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f03041e0ba7..c87b6119042 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2010-07-28 Daniel Kraft <d@domob.eu> + + * gfortran.h (gfc_build_intrinsic_call): New method. + * expr.c (gfc_build_intrinsic_call): New method. + * simplify.c (range_check): Ignore non-constant value. + (simplify_bound_dim): Handle non-variable expressions and + fix memory leak with non-free'ed expression. + (simplify_bound): Handle non-variable expressions. + (gfc_simplify_shape): Ditto. + (gfc_simplify_size): Ditto, but only in certain cases possible. + 2010-07-28 Joseph Myers <joseph@codesourcery.com> * gfortranspec.c (SWITCH_TAKES_ARG, WORD_SWITCH_TAKES_ARG): diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index cb7305ecf5a..661cac49a4d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4199,3 +4199,47 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict) return true; } + + +/* Build call to an intrinsic procedure. The number of arguments has to be + passed (rather than ending the list with a NULL value) because we may + want to add arguments but with a NULL-expression. */ + +gfc_expr* +gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...) +{ + gfc_expr* result; + gfc_actual_arglist* atail; + gfc_intrinsic_sym* isym; + va_list ap; + unsigned i; + + isym = gfc_find_function (name); + gcc_assert (isym); + + result = gfc_get_expr (); + result->expr_type = EXPR_FUNCTION; + result->ts = isym->ts; + result->where = where; + gfc_get_ha_sym_tree (isym->name, &result->symtree); + result->value.function.name = name; + result->value.function.isym = isym; + + va_start (ap, numarg); + atail = NULL; + for (i = 0; i < numarg; ++i) + { + if (atail) + { + atail->next = gfc_get_actual_arglist (); + atail = atail->next; + } + else + atail = result->value.function.actual = gfc_get_actual_arglist (); + + atail->expr = va_arg (ap, gfc_expr*); + } + va_end (ap); + + return result; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 15ae26f530c..d35a040d711 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2691,6 +2691,8 @@ bool gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); +gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...); + /* st.c */ extern gfc_code new_st; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7356625cf41..a77f6bd3544 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -73,6 +73,9 @@ range_check (gfc_expr *result, const char *name) if (result == NULL) return &gfc_bad_expr; + if (result->expr_type != EXPR_CONSTANT) + return result; + switch (gfc_range_check (result)) { case ARITH_OK: @@ -2727,24 +2730,52 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, gfc_expr *l, *u, *result; int k; + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* For non-variables, LBOUND(expr, DIM=n) = 1 and + UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ + if (!coarray && array->expr_type != EXPR_VARIABLE) + { + if (upper) + { + gfc_expr* dim = result; + mpz_set_si (dim->value.integer, d); + + result = gfc_simplify_size (array, dim, kind); + gfc_free_expr (dim); + if (!result) + goto returnNull; + } + else + mpz_set_si (result->value.integer, 1); + + goto done; + } + + /* Otherwise, we have a variable expression. */ + gcc_assert (array->expr_type == EXPR_VARIABLE); + gcc_assert (as); + /* The last dimension of an assumed-size array is special. */ if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) || (coarray && d == as->rank + as->corank)) { if (as->lower[d-1]->expr_type == EXPR_CONSTANT) - return gfc_copy_expr (as->lower[d-1]); - else - return NULL; - } + { + gfc_free_expr (result); + return gfc_copy_expr (as->lower[d-1]); + } - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; + goto returnNull; + } result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - /* Then, we need to know the extent of the given dimension. */ if (coarray || ref->u.ar.type == AR_FULL) { @@ -2753,7 +2784,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, if (l->expr_type != EXPR_CONSTANT || u == NULL || u->expr_type != EXPR_CONSTANT) - return NULL; + goto returnNull; if (mpz_cmp (l->value.integer, u->value.integer) > 0) { @@ -2778,13 +2809,18 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, { if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer) != SUCCESS) - return NULL; + goto returnNull; } else mpz_set_si (result->value.integer, (long int) 1); } +done: return range_check (result, upper ? "UBOUND" : "LBOUND"); + +returnNull: + gfc_free_expr (result); + return NULL; } @@ -2796,7 +2832,11 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) int d; if (array->expr_type != EXPR_VARIABLE) - return NULL; + { + as = NULL; + ref = NULL; + goto done; + } /* Follow any component references. */ as = array->symtree->n.sym->as; @@ -2815,7 +2855,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* We're done because 'as' has already been set in the previous iteration. */ if (!ref->next) - goto done; + goto done; /* Fall through. */ @@ -2842,7 +2882,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) return NULL; if (dim == NULL) @@ -2853,7 +2893,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) int k; /* UBOUND(ARRAY) is not valid for an assumed-size array. */ - if (upper && as->type == AS_ASSUMED_SIZE) + if (upper && as && as->type == AS_ASSUMED_SIZE) { /* An error message will be emitted in check_assumed_size_reference (resolve.c). */ @@ -2904,8 +2944,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > as->rank - || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper)) + if (d < 1 || d > array->rank + || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; @@ -4728,15 +4768,25 @@ gfc_simplify_shape (gfc_expr *source) return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &source->where); - if (source->expr_type != EXPR_VARIABLE) - return NULL; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &source->where); - ar = gfc_find_array_ref (source); - - t = gfc_array_ref_shape (ar, shape); + if (source->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (source); + t = gfc_array_ref_shape (ar, shape); + } + else if (source->shape) + { + t = SUCCESS; + for (n = 0; n < source->rank; n++) + { + mpz_init (shape[n]); + mpz_set (shape[n], source->shape[n]); + } + } + else + t = FAILURE; for (n = 0; n < source->rank; n++) { @@ -4760,9 +4810,7 @@ gfc_simplify_shape (gfc_expr *source) return NULL; } else - { - e = f; - } + e = f; } gfc_constructor_append_expr (&result->value.constructor, e, NULL); @@ -4782,6 +4830,56 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) if (k == -1) return &gfc_bad_expr; + /* For unary operations, the size of the result is given by the size + of the operand. For binary ones, it's the size of the first operand + unless it is scalar, then it is the size of the second. */ + if (array->expr_type == EXPR_OP && !array->value.op.uop) + { + gfc_expr* replacement; + gfc_expr* simplified; + + switch (array->value.op.op) + { + /* Unary operations. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + replacement = array->value.op.op1; + break; + + /* Binary operations. If any one of the operands is scalar, take + the other one's size. If both of them are arrays, it does not + matter -- try to find one with known shape, if possible. */ + default: + if (array->value.op.op1->rank == 0) + replacement = array->value.op.op2; + else if (array->value.op.op2->rank == 0) + replacement = array->value.op.op1; + else + { + simplified = gfc_simplify_size (array->value.op.op1, dim, kind); + if (simplified) + return simplified; + + replacement = array->value.op.op2; + } + break; + } + + /* Try to reduce it directly if possible. */ + simplified = gfc_simplify_size (replacement, dim, kind); + + /* Otherwise, we build a new SIZE call. This is hopefully at least + simpler than the original one. */ + if (!simplified) + simplified = gfc_build_intrinsic_call ("size", array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + gfc_copy_expr (kind)); + + return simplified; + } + if (dim == NULL) { if (gfc_array_size (array, &size) == FAILURE) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cd97c64605d..88b3691ed09 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2010-07-28 Daniel Kraft <d@domob.eu> + + * gfortran.dg/bound_8.f90: New test. + 2010-07-28 Jakub Jelinek <jakub@redhat.com> PR debug/45105 diff --git a/gcc/testsuite/gfortran.dg/bound_8.f90 b/gcc/testsuite/gfortran.dg/bound_8.f90 new file mode 100644 index 00000000000..046fc7eb2af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bound_8.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries -fall-intrinsics" } + +! Check that LBOUND/UBOUND/SIZE/SHAPE of array-expressions get simplified +! in certain cases. +! There should no array-temporaries warnings pop up, as this means that +! the intrinsic call has not been properly simplified. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + ! Some explicitely shaped arrays and allocatable ones. + INTEGER :: a(2, 3), b(0:1, 4:6) + INTEGER, ALLOCATABLE :: x(:, :), y(:, :) + + ! Allocate to matching sizes and initialize. + ALLOCATE (x(-1:0, -3:-1), y(11:12, 3)) + a = 0 + b = 1 + x = 2 + y = 3 + + ! Run the checks. This should be simplified without array temporaries, + ! and additionally correct (of course). + + ! Shape of expressions known at compile-time. + IF (ANY (LBOUND (a + b) /= 1)) CALL abort () + IF (ANY (UBOUND (2 * b) /= (/ 2, 3 /))) CALL abort () + IF (ANY (SHAPE (- b) /= (/ 2, 3 /))) CALL abort () + IF (SIZE (a ** 2) /= 6) CALL abort + + ! Shape unknown at compile-time. + IF (ANY (LBOUND (x + y) /= 1)) CALL abort () + IF (SIZE (x ** 2) /= 6) CALL abort () + + ! Unfortunately, the array-version of UBOUND and SHAPE keep generating + ! temporary arrays for their results (not for the operation). Thus we + ! can not check SHAPE in this case and do UBOUND in the single-dimension + ! version. + IF (UBOUND (2 * y, 1) /= 2 .OR. UBOUND (2 * y, 2) /= 3) CALL abort () + !IF (ANY (SHAPE (- y) /= (/ 2, 3 /))) CALL abort () +END PROGRAM main |