re PR fortran/29391 ([4.2/4.1 only] LBOUND and UBOUND are broken)
authorFrancois-Xavier Coudert <coudert@clipper.ens.fr>
Fri, 13 Oct 2006 12:20:28 +0000 (14:20 +0200)
committerFrançois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Fri, 13 Oct 2006 12:20:28 +0000 (12:20 +0000)
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
gcc/fortran/trans-intrinsic.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/bound_2.f90 [new file with mode: 0644]

index 5d1365aa0ac862c793047efef6f24f4bb3f9a0fc..9bf791b79fe11bbb27985cc82b434d8ace42acf3 100644 (file)
@@ -1,3 +1,9 @@
+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
index 811555d37cab3756d34100569237d49ac59a87d4..53c61c696d910db4b7470718d6b82bd866e40e09 100644 (file)
@@ -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);
index a59e5f1945665033bc4fc7f5fb45ad297cbff2c1..79424c2583c574626872e9c07710589e618fa7ae 100644 (file)
@@ -1,3 +1,8 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/bound_2.f90 b/gcc/testsuite/gfortran.dg/bound_2.f90
new file mode 100644 (file)
index 0000000..bd8cb4e
--- /dev/null
@@ -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