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

11 files changed, 183 insertions, 50 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7be7bdb..b388efc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,15 @@
 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
 	declaration before the first assignment.
 
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index acae59f..1b700b8 100644
--- 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 28e5a5b..5d234e6 100644
--- 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 be94219..7bcfda9 100644
--- 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 25ca135..75aa114 100644
--- 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 d68f1f9..44e278c 100644
--- 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
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 981e5cc2..344278e 100644
--- 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
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 e5071bd..86da3f8 100644
--- 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 96d4d8f..f9ff3b9 100644
--- 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