re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3)

2012-07-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * trans-intrinsic.c (gfc_conv_intrinsic_bound): Support
        lbound/ubound with dim= for assumed-rank arrays.
        * array.c (gfc_set_array_spec): Reject coarrays with
        assumed shape.
        * decl.c (merge_array_spec): Ditto. Return gfc_try.
        (match_attr_spec, match_attr_spec): Update call.

2012-07-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * gfortran.dg/assumed_rank_3.f90: New.
        * gfortran.dg/assumed_rank_11.f90: New.
        * gfortran.dg/assumed_rank_1.f90: Update dg-error.
        * gfortran.dg/assumed_rank_2.f90: Update dg-error.
        * gfortran.dg/assumed_rank_7.f90: Update dg-error.

From-SVN: r189743

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7be7bdb626c850fc79747299192752ab9e6683b6..b388efc22c5820359f57e41fbf2633f9846179de 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2012-07-21  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/48820
+       * trans-intrinsic.c (gfc_conv_intrinsic_bound): Support
+       lbound/ubound with dim= for assumed-rank arrays.
+       * array.c (gfc_set_array_spec): Reject coarrays with
+       assumed shape.
+       * decl.c (merge_array_spec): Ditto. Return gfc_try.
+       (match_attr_spec, match_attr_spec): Update call.
+
 2012-07-21  Tobias Burnus  <burnus@net-b.de>
 
        * resolve.c (resolve_formal_arglist): Put variable

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index acae59fecaedf48c877b931b58826136244e38ec..1b700b81109def13f7eae4784af9a9ddab57c004 100644 (file)
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -750,6 +750,14 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
       return SUCCESS;
     }
 
+  if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
+      || (as->type == AS_ASSUMED_RANK && sym->as->corank))
+    {
+      gfc_error ("The assumed-rank array '%s' at %L shall not have a "
+                "codimension", sym->name, error_loc);
+      return FAILURE;
+    }
+
   if (as->corank)
     {
       /* The "sym" has no corank (checked via gfc_add_codimension). Thus

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 28e5a5b4aedb6fb05fd16efd4aa1695b3d99f3ee..5d234e600e6a5f43ad001e43994ed16698835149 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -589,13 +589,17 @@ cleanup:
 
 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs.  */
 
-static void
+static gfc_try
 merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
 {
   int i;
 
-  gcc_assert (from->rank != -1 || to->corank == 0);
-  gcc_assert (to->rank != -1 || from->corank == 0);
+  if ((from->type == AS_ASSUMED_RANK && to->corank)
+      || (to->type == AS_ASSUMED_RANK && from->corank))
+    {
+      gfc_error ("The assumed-rank array at %C shall not have a codimension");
+      return FAILURE;
+    }
 
   if (to->rank == 0 && from->rank > 0)
     {
@@ -642,6 +646,8 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
            }
        }
     }
+
+  return SUCCESS;
 }
 
 
@@ -1799,8 +1805,12 @@ variable_decl (int elem)
 
   if (m == MATCH_NO)
     as = gfc_copy_array_spec (current_as);
-  else if (current_as)
-    merge_array_spec (current_as, as, true);
+  else if (current_as
+          && merge_array_spec (current_as, as, true) == FAILURE)
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
 
   if (gfc_option.flag_cray_pointer)
     cp_as = gfc_copy_array_spec (as);
@@ -3512,7 +3522,8 @@ match_attr_spec (void)
            current_as = as;
          else if (m == MATCH_YES)
            {
-             merge_array_spec (as, current_as, false);
+             if (merge_array_spec (as, current_as, false) == FAILURE)
+               m = MATCH_ERROR;
              free (as);
            }
 

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index be9421944e080033fd38948fc4c54804c76ed6c3..7bcfda9301d3f9d44a42340503a3befc03a92cc8 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1367,6 +1367,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   gfc_se argse;
   gfc_ss *ss;
   gfc_array_spec * as;
+  bool assumed_rank_lb_one;
 
   arg = expr->value.function.actual;
   arg2 = arg->next;
@@ -1408,27 +1409,36 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   desc = argse.expr;
 
+  as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
   if (INTEGER_CST_P (bound))
     {
       int hi, low;
 
       hi = TREE_INT_CST_HIGH (bound);
       low = TREE_INT_CST_LOW (bound);
-      if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+      if (hi || low < 0
+         || ((!as || as->type != AS_ASSUMED_RANK)
+             && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+         || low > GFC_MAX_DIMENSIONS)
        gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
                   "dimension index", upper ? "UBOUND" : "LBOUND",
                   &expr->where);
     }
-  else
+
+  if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
     {
       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
         {
           bound = gfc_evaluate_now (bound, &se->pre);
           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
                                  bound, build_int_cst (TREE_TYPE (bound), 0));
-          tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+         if (as && as->type == AS_ASSUMED_RANK)
+           tmp = get_rank_from_desc (desc);
+         else
+           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
-                                bound, tmp);
+                                bound, fold_convert(TREE_TYPE (bound), tmp));
           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
                                  boolean_type_node, cond, tmp);
           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
@@ -1436,11 +1446,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
         }
     }
 
+  /* Take care of the lbound shift for assumed-rank arrays, which are
+     nonallocatable and nonpointers. Those has a lbound of 1.  */
+  assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
+                       && ((arg->expr->ts.type != BT_CLASS
+                            && !arg->expr->symtree->n.sym->attr.allocatable
+                            && !arg->expr->symtree->n.sym->attr.pointer)
+                           || (arg->expr->ts.type == BT_CLASS
+                            && !CLASS_DATA (arg->expr)->attr.allocatable
+                            && !CLASS_DATA (arg->expr)->attr.class_pointer));
+
   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
   
-  as = gfc_get_full_arrayspec_from_expr (arg->expr);
-
   /* 13.14.53: Result value for LBOUND
 
      Case (i): For an array section or for an array expression other than a
@@ -1462,7 +1480,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
                not have size zero and has value zero if dimension DIM has
                size zero.  */
 
-  if (as)
+  if (!upper && assumed_rank_lb_one)
+    se->expr = gfc_index_one_node;
+  else if (as)
     {
       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
 
@@ -1488,9 +1508,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
          cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
                                  boolean_type_node, cond, cond5);
 
+         if (assumed_rank_lb_one)
+           {
+             tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                              gfc_array_index_type, ubound, lbound);
+             tmp = fold_build2_loc (input_location, PLUS_EXPR,
+                              gfc_array_index_type, tmp, gfc_index_one_node);
+           }
+          else
+            tmp = ubound;
+
          se->expr = fold_build3_loc (input_location, COND_EXPR,
                                      gfc_array_index_type, cond,
-                                     ubound, gfc_index_zero_node);
+                                     tmp, gfc_index_zero_node);
        }
       else
        {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 25ca1359f97f142f2c6c2476edf794b3cd0d4bb3..75aa11414049299c8a68736418897aa707afeb30 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2012-07-21  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/48820
+       * gfortran.dg/assumed_rank_3.f90: New.
+       * gfortran.dg/assumed_rank_11.f90: New.
+       * gfortran.dg/assumed_rank_1.f90: Update dg-error.
+       * gfortran.dg/assumed_rank_2.f90: Update dg-error.
+       * gfortran.dg/assumed_rank_7.f90: Update dg-error.
+
 2012-07-21  Andrew Pinski  <apinski@cavium.com>
 
        * gcc.target/mips/unaligned-1.c: New testcase.

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
index d68f1f91565f3b2f4765635713010217df2967d0..44e278c37f617235a6c431c1ed22076bdff9e8bb 100644 (file)
--- a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
@@ -5,8 +5,6 @@
 !
 ! Assumed-rank tests
 !
-! FIXME: The ubound/lbound checks have to be re-enabled when
-! after they are supported
 
 implicit none
 
@@ -106,14 +104,14 @@ contains
     if (size(a) /= product (high - low +1)) call abort()
 
     if (rnk > 0) then
-!      if (1 /= lbound(a,1)) call abort()
-!      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+      if (1 /= lbound(a,1)) call abort()
+      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
       if (size (a,1) /= high(1)-low(1)+1) call abort()
     end if
 
     do i = 1, rnk
-!      if (1 /= lbound(a,i)) call abort()
-!      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+      if (1 /= lbound(a,i)) call abort()
+      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
       if (size (a,i) /= high(i)-low(i)+1) call abort()
     end do
     call check_value (a, rnk, val)
@@ -131,14 +129,14 @@ contains
     if (size(a) /= product (high - low +1)) call abort()
 
     if (rnk > 0) then
-!      if (low(1) /= lbound(a,1)) call abort()
-!      if (high(1) /= ubound(a,1)) call abort()
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
       if (size (a,1) /= high(1)-low(1)+1) call abort()
     end if
 
     do i = 1, rnk
-!      if (low(i) /= lbound(a,i)) call abort()
-!      if (high(i) /= ubound(a,i)) call abort()
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
       if (size (a,i) /= high(i)-low(i)+1) call abort()
     end do
     call check_value (a, rnk, val)

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_11.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_11.f90
new file mode 100644 (file)
index 0000000..46dffd0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_11.f90
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+subroutine foo(X)
+ integer :: x(..)
+ codimension :: x[*] ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine foo2(X)
+ integer, dimension(..) :: x[*] ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
+end
+
+subroutine foo3(X)
+ integer, codimension[*] :: x(..) ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
+end
+
+subroutine foo4(X)
+ integer, codimension[*], dimension(..) :: x ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
+end
+
+subroutine bar(X)
+ integer :: x[*]
+ dimension :: x(..) ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine foobar(X)
+ integer :: x
+ codimension :: x[*]
+ dimension :: x(..) ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine barfoo(X)
+ integer :: x
+ dimension :: x(..)
+ codimension :: x[*] ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine orig(X) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer :: x(..)[*]
+end
+
+subroutine val1(X)
+ integer, value :: x(..)  ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" }
+end
+
+subroutine val2(X)
+ integer, value :: x
+ dimension :: x(..)  ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" }
+end

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
index 981e5cc2f9233f046fc87c6d297d0bbb54f5e23c..344278e163217469542c61cefd29fe7709195851 100644 (file)
--- a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
@@ -6,8 +6,6 @@
 ! Assumed-rank tests - same as assumed_rank_1.f90,
 ! but with bounds checks and w/o call to C function
 !
-! FIXME: The ubound/lbound checks have to be re-enabled when
-! after they are supported
 
 implicit none
 
@@ -73,14 +71,14 @@ contains
     if (size(a) /= product (high - low +1)) call abort()
 
     if (rnk > 0) then
-!      if (low(1) /= lbound(a,1)) call abort()
-!      if (high(1) /= ubound(a,1)) call abort()
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
       if (size (a,1) /= high(1)-low(1)+1) call abort()
     end if
 
     do i = 1, rnk
-!      if (low(i) /= lbound(a,i)) call abort()
-!      if (high(i) /= ubound(a,i)) call abort()
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
       if (size (a,i) /= high(i)-low(i)+1) call abort()
     end do
     call foo2(a, rnk, low, high, val)
@@ -98,14 +96,14 @@ contains
     if (size(a) /= product (high - low +1)) call abort()
 
     if (rnk > 0) then
-!      if (1 /= lbound(a,1)) call abort()
-!      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+      if (1 /= lbound(a,1)) call abort()
+      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
       if (size (a,1) /= high(1)-low(1)+1) call abort()
     end if
 
     do i = 1, rnk
-!      if (1 /= lbound(a,i)) call abort()
-!      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+      if (1 /= lbound(a,i)) call abort()
+      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
       if (size (a,i) /= high(i)-low(i)+1) call abort()
     end do
   end subroutine foo2
@@ -122,14 +120,14 @@ contains
     if (size(a) /= product (high - low +1)) call abort()
 
     if (rnk > 0) then
-!      if (low(1) /= lbound(a,1)) call abort()
-!      if (high(1) /= ubound(a,1)) call abort()
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
       if (size (a,1) /= high(1)-low(1)+1) call abort()
     end if
 
     do i = 1, rnk
-!      if (low(i) /= lbound(a,i)) call abort()
-!      if (high(i) /= ubound(a,i)) call abort()
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
       if (size (a,i) /= high(i)-low(i)+1) call abort()
     end do
     call foo(a, rnk, low, high, val)

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_3.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_3.f90
new file mode 100644 (file)
index 0000000..ab5c0d9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_3.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array reference out of bounds" }
+!
+! PR fortran/48820
+!
+! Do assumed-rank bound checking
+
+implicit none
+integer :: a(4,4)
+call bar(a)
+contains
+  subroutine bar(x)
+    integer :: x(..)
+    print *, ubound(x,dim=3)  ! << wrong dim
+  end subroutine
+end
+
+! { dg-output "Fortran runtime error: Array reference out of bounds" }

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_6.f90
index e5071bda9ed11b025e3ba953bfd7e04f34f70e65..86da3f853c3a05df6cc6988e518a06c987e08b62 100644 (file)
--- a/gcc/testsuite/gfortran.dg/assumed_rank_6.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_6.f90
@@ -30,8 +30,8 @@ contains
   end subroutine
 end subroutine
 
-subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
-  integer, codimension[*] :: x(..)
+subroutine foo4(x)
+  integer, codimension[*] :: x(..) ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
 end subroutine
 
 subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_7.f90
index 96d4d8f386a06df5e1fb7a653a69c36ac7b513bd..f9ff3b9aa424531d9cf6a4526fba72e751d38ff1 100644 (file)
--- a/gcc/testsuite/gfortran.dg/assumed_rank_7.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_7.f90
@@ -4,8 +4,6 @@
 !
 ! Handle type/class for assumed-rank arrays
 !
-! FIXME: The ubound/lbound checks have to be re-enabled when
-! after they are supported.
 ! FIXME: Passing a CLASS to a CLASS has to be re-enabled.
 implicit none
 type t
@@ -29,38 +27,38 @@ if (i /= 12) call abort()
 contains
   subroutine bar(x)
     type(t) :: x(..)
-!    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
     if (size(x) /= 6) call abort()
     if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
-!    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
     i = i + 1
     call foo(x)
     call bar2(x)
   end subroutine
   subroutine bar2(x)
     type(t) :: x(..)
-!    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
     if (size(x) /= 6) call abort()
     if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
-!    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
     i = i + 1
   end subroutine
   subroutine foo(x)
     class(t) :: x(..)
-!    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
     if (size(x) /= 6) call abort()
     if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
-!    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
     i = i + 1
     call foo2(x)
 !    call bar2(x) ! Passing a CLASS to a TYPE does not yet work
   end subroutine
   subroutine foo2(x)
     class(t) :: x(..)
-!    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+    if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
     if (size(x) /= 6) call abort()
     if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
-!    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+    if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
     i = i + 1
   end subroutine
 end