===================================================================
@@ -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;
===================================================================
@@ -4199,3 +4199,47 @@ gfc_is_simply_contiguous (gfc_expr *expr
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;
+}
===================================================================
@@ -73,6 +73,9 @@ range_check (gfc_expr *result, const cha
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
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
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
{
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_exp
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_exp
/* 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_exp
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_exp
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_exp
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,46 @@ gfc_simplify_size (gfc_expr *array, gfc_
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. */
+ default:
+ if (array->value.op.op1->rank == 0)
+ replacement = array->value.op.op2;
+ else
+ replacement = array->value.op.op1;
+ 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)
===================================================================
@@ -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