gfortran.h (gfc_build_intrinsic_call): New method.

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

gcc/fortran/ChangeLog

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

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

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;

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)
+	{
+	  gfc_free_expr (result);
 	  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)
-    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;
@@ -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)

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/bound_8.f90

+! { 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