This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran 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]

[Patch, Fortran] assumed-rank some bound intrinsics support, fix failures and improve diagnostcs


Dear all,

this patch is a cleanup follow up to the assumed-rank patch. Changes:
* Fix pattern matching for the dump. for some reason, the DTYPE differes between i686 and x86-64.
* There was a proper check missing that assumed-rank arrays may not have a codimension. (There are now checks in array.c, decl.c and - preexisting - resolve.c, all are triggered by the test case _11.)
* I re-added my lbound/ubound patch. It still only works with dim=.


For lbound/ubound without dim= and for shape, one has to modify the scalarizer a bit. See discussion at http://gcc.gnu.org/ml/fortran/2012-07/msg00032.html


Mikael: I wouldn't mind if you could have a look at the scalarizer - you seem to have an idea how one can implement it with minimal effort/code cluttering.



Build and regtested on x86-64-linux. OK for the trunk?

Tobias

PS: Sorry for missing the regression failure before the committal.

2012-07-20  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-20  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.
	* gfortran.dg/assumed_rank_12.f90: Update dg-error.

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 66e2ca8..c836b25 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;
 }
 
 
@@ -1813,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);
@@ -3526,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/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_12.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
index a2abcba..f947f49 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
@@ -16,6 +16,6 @@ function f() result(res)
 end function f
 end
 
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" "original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 
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_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 
--- /dev/null	2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_3.f90	2012-06-24 15:17:43.000000000 +0200
@@ -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" }
--- /dev/null	2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_11.f90	2012-07-20 10:35:39.000000000 +0200
@@ -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

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