mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-10 23:17:48 +08:00
Code Issues Packages Projects Releases Wiki Activity

gfortran.h (gfc_build_intrinsic_call): New method.

Browse Source 
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.

From-SVN: r162648
This commit is contained in:
Daniel Kraft 2010-07-28 19:06:40 +02:00 committed by Daniel Kraft
parent 05b5ea3495
commit 69dcd06ab8
6 changed files with 230 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -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):

44
gcc/fortran/expr.c
View File

@ -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;
}

2
gcc/fortran/gfortran.h
View File

@ -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;

144
gcc/fortran/simplify.c
View File

@ -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,16 +2730,6 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
gfc_expr *l, *u, *result;
int k;
/* 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;
}
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind);
if (k == -1)
@ -2744,6 +2737,44 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
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)
{
gfc_free_expr (result);
return gfc_copy_expr (as->lower[d-1]);
}
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;
@ -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);
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,10 +4810,8 @@ gfc_simplify_shape (gfc_expr *source)
return NULL;
}
else
{
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)

4
gcc/testsuite/ChangeLog
View File

@ -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

44
gcc/testsuite/gfortran.dg/bound_8.f90 Normal file
View File

@ -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