re PR fortran/29391 ([4.2/4.1 only] LBOUND and UBOUND are broken)

	PR fortran/29391

	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Generate correct
	code for LBOUND and UBOUND intrinsics.

	* gfortran.dg/bound_2.f90: New test.

From-SVN: r117691

gcc/fortran/ChangeLog

 2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
+	PR fortran/29391
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Generate correct
+	code for LBOUND and UBOUND intrinsics.
+
+2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
 	PR fortran/21435
 	* io.c (compare_to_allowed_values): New function.
 	(gfc_match_open): Add checks for constant values of specifiers.

gcc/fortran/trans-intrinsic.c

@@ -710,9 +710,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   tree type;
   tree bound;
   tree tmp;
-  tree cond;
+  tree cond, cond1, cond2, cond3, size;
+  tree ubound;
+  tree lbound;
   gfc_se argse;
   gfc_ss *ss;
+  gfc_array_spec * as;
+  gfc_ref *ref;
   int i;
 
   arg = expr->value.function.actual;
@@ -773,10 +777,111 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
         }
     }
 
-  if (upper)
-    se->expr = gfc_conv_descriptor_ubound(desc, bound);
+  ubound = gfc_conv_descriptor_ubound (desc, bound);
+  lbound = gfc_conv_descriptor_lbound (desc, bound);
+  
+  /* Follow any component references.  */
+  if (arg->expr->expr_type == EXPR_VARIABLE
+      || arg->expr->expr_type == EXPR_CONSTANT)
+    {
+      as = arg->expr->symtree->n.sym->as;
+      for (ref = arg->expr->ref; ref; ref = ref->next)
+	{
+	  switch (ref->type)
+	    {
+	    case REF_COMPONENT:
+	      as = ref->u.c.component->as;
+	      continue;
+
+	    case REF_SUBSTRING:
+	      continue;
+
+	    case REF_ARRAY:
+	      {
+		switch (ref->u.ar.type)
+		  {
+		  case AR_ELEMENT:
+		  case AR_SECTION:
+		  case AR_UNKNOWN:
+		    as = NULL;
+		    continue;
+
+		  case AR_FULL:
+		    break;
+		  }
+	      }
+	    }
+	}
+    }
+  else
+    as = NULL;
+
+  /* 13.14.53: Result value for LBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, LBOUND(ARRAY, DIM)
+               has the value 1.  For a whole array or array structure
+               component, LBOUND(ARRAY, DIM) has the value:
+                 (a) equal to the lower bound for subscript DIM of ARRAY if
+                     dimension DIM of ARRAY does not have extent zero
+                     or if ARRAY is an assumed-size array of rank DIM,
+              or (b) 1 otherwise.
+
+     13.14.113: Result value for UBOUND
+
+     Case (i): For an array section or for an array expression other than a
+               whole array or array structure component, UBOUND(ARRAY, DIM)
+               has the value equal to the number of elements in the given
+               dimension; otherwise, it has a value equal to the upper bound
+               for subscript DIM of ARRAY if dimension DIM of ARRAY does
+               not have size zero and has value zero if dimension DIM has
+               size zero.  */
+
+  if (as)
+    {
+      tree stride = gfc_conv_descriptor_stride (desc, bound);
+      cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
+      cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
+      cond3 = fold_build2 (GT_EXPR, boolean_type_node, stride,
+			   gfc_index_zero_node);
+
+      if (upper)
+	{
+	  cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond2);
+
+	  se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+				  ubound, gfc_index_zero_node);
+	}
+      else
+	{
+	  if (as->type == AS_ASSUMED_SIZE)
+	    cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+				build_int_cst (TREE_TYPE (bound),
+					       arg->expr->rank));
+	  else
+	    cond = boolean_false_node;
+
+	  cond1 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+	  cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond1, cond2);
+
+	  cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+
+	  se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+				  lbound, gfc_index_one_node);
+	}
+    }
   else
-    se->expr = gfc_conv_descriptor_lbound(desc, bound);
+    {
+      if (upper)
+        {
+	  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+	  se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+				  gfc_index_one_node);
+	}
+      else
+	se->expr = gfc_index_one_node;
+    }
 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);

gcc/testsuite/ChangeLog

 2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
+	PR fortran/29391
+	* gfortran.dg/bound_2.f90: New test.
+
+2006-10-13  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
 	* gfortran.dg/defined_operators_1.f90: Add cleanup-modules dg
 	directive.
 	* gfortran.dg/module_private_array_refs_1.f90: Likewise.

gcc/testsuite/gfortran.dg/bound_2.f90

+! { dg-do run }
+! PR fortran/29391
+! This file is here to check that LBOUND and UBOUND return correct values
+!
+! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr)
+  implicit none
+  integer :: i(-1:1,-1:1) = 0
+  integer :: j(-1:2) = 0
+
+  if (any(lbound(i(-1:1,-1:1)) /= 1)) call abort
+  if (any(ubound(i(-1:1,-1:1)) /= 3)) call abort
+  if (any(lbound(i(:,:)) /= 1)) call abort
+  if (any(ubound(i(:,:)) /= 3)) call abort
+  if (any(lbound(i(0:,-1:)) /= 1)) call abort
+  if (any(ubound(i(0:,-1:)) /= [2,3])) call abort
+  if (any(lbound(i(:0,:0)) /= 1)) call abort
+  if (any(ubound(i(:0,:0)) /= 2)) call abort
+
+  if (any(lbound(transpose(i)) /= 1)) call abort
+  if (any(ubound(transpose(i)) /= 3)) call abort
+  if (any(lbound(reshape(i,[2,2])) /= 1)) call abort
+  if (any(ubound(reshape(i,[2,2])) /= 2)) call abort
+  if (any(lbound(cshift(i,-1)) /= 1)) call abort
+  if (any(ubound(cshift(i,-1)) /= 3)) call abort
+  if (any(lbound(eoshift(i,-1)) /= 1)) call abort
+  if (any(ubound(eoshift(i,-1)) /= 3)) call abort
+  if (any(lbound(spread(i,1,2)) /= 1)) call abort
+  if (any(ubound(spread(i,1,2)) /= [2,3,3])) call abort
+  if (any(lbound(maxloc(i)) /= 1)) call abort
+  if (any(ubound(maxloc(i)) /= 2)) call abort
+  if (any(lbound(minloc(i)) /= 1)) call abort
+  if (any(ubound(minloc(i)) /= 2)) call abort
+  if (any(lbound(maxval(i,2)) /= 1)) call abort
+  if (any(ubound(maxval(i,2)) /= 3)) call abort
+  if (any(lbound(minval(i,2)) /= 1)) call abort
+  if (any(ubound(minval(i,2)) /= 3)) call abort
+  if (any(lbound(any(i==1,2)) /= 1)) call abort
+  if (any(ubound(any(i==1,2)) /= 3)) call abort
+  if (any(lbound(count(i==1,2)) /= 1)) call abort
+  if (any(ubound(count(i==1,2)) /= 3)) call abort
+  if (any(lbound(merge(i,i,.true.)) /= 1)) call abort
+  if (any(ubound(merge(i,i,.true.)) /= 3)) call abort
+  if (any(lbound(lbound(i)) /= 1)) call abort
+  if (any(ubound(lbound(i)) /= 2)) call abort
+  if (any(lbound(ubound(i)) /= 1)) call abort
+  if (any(ubound(ubound(i)) /= 2)) call abort
+  if (any(lbound(shape(i)) /= 1)) call abort
+  if (any(ubound(shape(i)) /= 2)) call abort
+
+  if (any(lbound(product(i,2)) /= 1)) call abort
+  if (any(ubound(product(i,2)) /= 3)) call abort
+  if (any(lbound(sum(i,2)) /= 1)) call abort
+  if (any(ubound(sum(i,2)) /= 3)) call abort
+  if (any(lbound(matmul(i,i)) /= 1)) call abort
+  if (any(ubound(matmul(i,i)) /= 3)) call abort
+  if (any(lbound(pack(i,.true.)) /= 1)) call abort
+  if (any(ubound(pack(i,.true.)) /= 9)) call abort
+  if (any(lbound(unpack(j,[.true.],[2])) /= 1)) call abort
+  if (any(ubound(unpack(j,[.true.],[2])) /= 1)) call abort
+
+  call sub1(i,3)
+  call sub1(reshape([7,9,4,6,7,9],[3,2]),3)
+
+contains
+
+  subroutine sub1(a,n)
+    integer :: a(2:n+1,4:*), n
+    if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) call abort
+    if (any(lbound(a) /= [2, 4])) call abort
+  end subroutine sub1
+
+end