This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[gfortran,commited] Fix LBOUND and UBOUND intrinsics


Hi all,

I commited the attached patch to mainline (rev. 117691) so that
gfortran generates correct code for LBOUND and UBOUND intrinsics
(which were broken in a large number of cases, see PR29391).

It was OKed by Paul Thomas on IRC, and regtested on x86_64-linux. I
intend to backport the patch to the 4.1 branch in a week or so.

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.
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 117683)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -710,9 +710,13 @@
   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,11 +777,112 @@
         }
     }
 
-  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
-    se->expr = gfc_conv_descriptor_lbound(desc, bound);
+    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
+    {
+      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);
 }
Index: gcc/testsuite/gfortran.dg/bound_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/bound_2.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/bound_2.f90	(revision 0)
@@ -0,0 +1,72 @@
+! { 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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]