re PR fortran/31399 (Wrong code for do loop with large interation count)

	PR fortran/31399

	* trans-stmt.c (gfc_trans_do): Handle large loop counts.

	* gfortran.dg/do_3.F90: New test.

From-SVN: r124496

gcc/fortran/ChangeLog

 2007-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+	PR fortran/31399
+	* trans-stmt.c (gfc_trans_do): Handle large loop counts.
+
+2007-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
 	PR fortran/31764
 	* simplify.c (gfc_simplify_new_line): NEW_LINE can be simplified
 	even for non constant arguments.

gcc/fortran/trans-stmt.c

@@ -809,22 +809,22 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
    to:
 
    [evaluate loop bounds and step]
-   count = (to + step - from) / step;
+   empty = (step > 0 ? to < from : to > from);
+   countm1 = (to - from) / step;
    dovar = from;
+   if (empty) goto exit_label;
    for (;;)
      {
        body;
 cycle_label:
        dovar += step
-       count--;
-       if (count <=0) goto exit_label;
+       countm1--;
+       if (countm1 ==0) goto exit_label;
      }
 exit_label:
 
-   TODO: Large loop counts
-   The code above assumes the loop count fits into a signed integer kind,
-   i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
-   We must support the full range.  */
+   countm1 is an unsigned integer.  It is equal to the loop count minus one,
+   because the loop count itself can overflow.  */
 
 tree
 gfc_trans_do (gfc_code * code)
@@ -834,13 +834,15 @@ gfc_trans_do (gfc_code * code)
   tree from;
   tree to;
   tree step;
-  tree count;
-  tree count_one;
+  tree empty;
+  tree countm1;
   tree type;
+  tree utype;
   tree cond;
   tree cycle_label;
   tree exit_label;
   tree tmp;
+  tree pos_step;
   stmtblock_t block;
   stmtblock_t body;
 
@@ -874,48 +876,59 @@ gfc_trans_do (gfc_code * code)
 	|| tree_int_cst_equal (step, integer_minus_one_node)))
     return gfc_trans_simple_do (code, &block, dovar, from, to, step);
       
-  /* Initialize loop count. This code is executed before we enter the
-     loop body. We generate: count = (to + step - from) / step.  */
+  /* We need a special check for empty loops:
+     empty = (step > 0 ? to < from : to > from);  */
+  pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
+			  fold_convert (type, integer_zero_node));
+  empty = fold_build3 (COND_EXPR, boolean_type_node, pos_step,
+		       fold_build2 (LT_EXPR, boolean_type_node, to, from),
+		       fold_build2 (GT_EXPR, boolean_type_node, to, from));
 
-  tmp = fold_build2 (MINUS_EXPR, type, step, from);
-  tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
+  /* Initialize loop count. This code is executed before we enter the
+     loop body. We generate: countm1 = abs(to - from) / abs(step).  */
   if (TREE_CODE (type) == INTEGER_TYPE)
     {
-      tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
-      count = gfc_create_var (type, "count");
+      tree ustep;
+
+      utype = gfc_unsigned_type (type);
+
+      /* tmp = abs(to - from) / abs(step) */
+      ustep = fold_convert (utype, fold_build1 (ABS_EXPR, type, step));
+      tmp = fold_build3 (COND_EXPR, type, pos_step,
+			 fold_build2 (MINUS_EXPR, type, to, from),
+			 fold_build2 (MINUS_EXPR, type, from, to));
+      tmp = fold_build2 (TRUNC_DIV_EXPR, utype, fold_convert (utype, tmp),
+			 ustep);
     }
   else
     {
       /* TODO: We could use the same width as the real type.
 	 This would probably cause more problems that it solves
 	 when we implement "long double" types.  */
+      utype = gfc_unsigned_type (gfc_array_index_type);
+      tmp = fold_build2 (MINUS_EXPR, type, to, from);
       tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
-      tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
-      count = gfc_create_var (gfc_array_index_type, "count");
+      tmp = fold_build1 (FIX_TRUNC_EXPR, utype, tmp);
     }
-  gfc_add_modify_expr (&block, count, tmp);
+  countm1 = gfc_create_var (utype, "countm1");
+  gfc_add_modify_expr (&block, countm1, tmp);
 
-  count_one = build_int_cst (TREE_TYPE (count), 1);
+  /* Cycle and exit statements are implemented with gotos.  */
+  cycle_label = gfc_build_label_decl (NULL_TREE);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
 
   /* Initialize the DO variable: dovar = from.  */
   gfc_add_modify_expr (&block, dovar, from);
 
+  /* If the loop is empty, go directly to the exit label.  */
+  tmp = fold_build3 (COND_EXPR, void_type_node, empty,
+		     build1_v (GOTO_EXPR, exit_label), build_empty_stmt ());
+  gfc_add_expr_to_block (&block, tmp);
+
   /* Loop body.  */
   gfc_start_block (&body);
 
-  /* Cycle and exit statements are implemented with gotos.  */
-  cycle_label = gfc_build_label_decl (NULL_TREE);
-  exit_label = gfc_build_label_decl (NULL_TREE);
-
-  /* Start with the loop condition.  Loop until count <= 0.  */
-  cond = fold_build2 (LE_EXPR, boolean_type_node, count,
-		      build_int_cst (TREE_TYPE (count), 0));
-  tmp = build1_v (GOTO_EXPR, exit_label);
-  TREE_USED (exit_label) = 1;
-  tmp = fold_build3 (COND_EXPR, void_type_node,
-		     cond, tmp, build_empty_stmt ());
-  gfc_add_expr_to_block (&body, tmp);
-
   /* Put these labels where they can be found later. We put the
      labels in a TREE_LIST node (because TREE_CHAIN is already
      used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
@@ -934,13 +947,21 @@ gfc_trans_do (gfc_code * code)
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* End with the loop condition.  Loop until countm1 == 0.  */
+  cond = fold_build2 (EQ_EXPR, boolean_type_node, countm1,
+		      build_int_cst (utype, 0));
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  tmp = fold_build3 (COND_EXPR, void_type_node,
+		     cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&body, tmp);
+
   /* Increment the loop variable.  */
   tmp = build2 (PLUS_EXPR, type, dovar, step);
   gfc_add_modify_expr (&body, dovar, tmp);
 
   /* Decrement the loop count.  */
-  tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
-  gfc_add_modify_expr (&body, count, tmp);
+  tmp = build2 (MINUS_EXPR, utype, countm1, build_int_cst (utype, 1));
+  gfc_add_modify_expr (&body, countm1, tmp);
 
   /* End of loop body.  */
   tmp = gfc_finish_block (&body);

gcc/testsuite/ChangeLog

 2007-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+	PR fortran/31399
+	* gfortran.dg/do_3.F90: New test.
+
+2007-05-07  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
 	PR fortran/31764
 	* gfortran.dg/new_line.f90: Add new checks.
 

gcc/testsuite/gfortran.dg/do_3.F90

+! { dg-do run }
+! { dg-options "-std=legacy -ffree-line-length-none" }
+program test
+  integer :: count
+  integer :: i
+  integer(kind=1) :: i1
+  real :: r
+
+#define TEST_LOOP(var,from,to,step,total,test) \
+  count = 0 ; do var = from, to, step ; count = count + 1 ; end do ; \
+  if (count /= total) call abort ; \
+  if (test (from, to, step) /= total) call abort
+
+  ! Integer loops
+  TEST_LOOP(i, 0, 0, 1, 1, test_i)
+  TEST_LOOP(i, 0, 0, 2, 1, test_i)
+  TEST_LOOP(i, 0, 0, -1, 1, test_i)
+  TEST_LOOP(i, 0, 0, -2, 1, test_i)
+
+  TEST_LOOP(i, 0, 1, 1, 2, test_i)
+  TEST_LOOP(i, 0, 1, 2, 1, test_i)
+  TEST_LOOP(i, 0, 1, 3, 1, test_i)
+  TEST_LOOP(i, 0, 1, huge(0), 1, test_i)
+  TEST_LOOP(i, 0, 1, -1, 0, test_i)
+  TEST_LOOP(i, 0, 1, -2, 0, test_i)
+  TEST_LOOP(i, 0, 1, -3, 0, test_i)
+  TEST_LOOP(i, 0, 1, -huge(0), 0, test_i)
+  TEST_LOOP(i, 0, 1, -huge(0)-1, 0, test_i)
+
+  TEST_LOOP(i, 1, 0, 1, 0, test_i)
+  TEST_LOOP(i, 1, 0, 2, 0, test_i)
+  TEST_LOOP(i, 1, 0, 3, 0, test_i)
+  TEST_LOOP(i, 1, 0, huge(0), 0, test_i)
+  TEST_LOOP(i, 1, 0, -1, 2, test_i)
+  TEST_LOOP(i, 1, 0, -2, 1, test_i)
+  TEST_LOOP(i, 1, 0, -3, 1, test_i)
+  TEST_LOOP(i, 1, 0, -huge(0), 1, test_i)
+  TEST_LOOP(i, 1, 0, -huge(0)-1, 1, test_i)
+
+  TEST_LOOP(i, 0, 17, 1, 18, test_i)
+  TEST_LOOP(i, 0, 17, 2, 9, test_i)
+  TEST_LOOP(i, 0, 17, 3, 6, test_i)
+  TEST_LOOP(i, 0, 17, 4, 5, test_i)
+  TEST_LOOP(i, 0, 17, 5, 4, test_i)
+  TEST_LOOP(i, 17, 0, -1, 18, test_i)
+  TEST_LOOP(i, 17, 0, -2, 9, test_i)
+  TEST_LOOP(i, 17, 0, -3, 6, test_i)
+  TEST_LOOP(i, 17, 0, -4, 5, test_i)
+  TEST_LOOP(i, 17, 0, -5, 4, test_i)
+
+  TEST_LOOP(i1, -huge(i1)-1_1, huge(i1), 1_1, int(huge(i1))*2+2, test_i1)
+  TEST_LOOP(i1, -huge(i1)-1_1, huge(i1), 2_1, int(huge(i1))+1, test_i1)
+  TEST_LOOP(i1, -huge(i1)-1_1, huge(i1), huge(i1), 3, test_i1)
+
+  TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -1_1, int(huge(i1))*2+2, test_i1)
+  TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -2_1, int(huge(i1))+1, test_i1)
+  TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -huge(i1), 3, test_i1)
+  TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -huge(i1)-1_1, 2, test_i1)
+
+  TEST_LOOP(i1, -2_1, 3_1, huge(i1), 1, test_i1)
+  TEST_LOOP(i1, -2_1, 3_1, -huge(i1), 0, test_i1)
+  TEST_LOOP(i1, 2_1, -3_1, -huge(i1), 1, test_i1)
+  TEST_LOOP(i1, 2_1, -3_1, huge(i1), 0, test_i1)
+
+  ! Real loops
+  TEST_LOOP(r, 0.0, 1.0, 0.11, 1 + int(1.0/0.11), test_r)
+  TEST_LOOP(r, 0.0, 1.0, -0.11, 0, test_r)
+  TEST_LOOP(r, 0.0, -1.0, 0.11, 0, test_r)
+  TEST_LOOP(r, 0.0, -1.0, -0.11, 1 + int(1.0/0.11), test_r)
+  TEST_LOOP(r, 0.0, 0.0, 0.11, 1, test_r)
+  TEST_LOOP(r, 0.0, 0.0, -0.11, 1, test_r)
+
+#undef TEST_LOOP
+
+contains
+
+  function test_i1 (from, to, step) result(res)
+    integer(kind=1), intent(in) :: from, to, step
+    integer(kind=1) :: i
+    integer :: res
+
+    res = 0
+    do i = from, to, step
+      res = res + 1
+    end do
+  end function test_i1
+
+  function test_i (from, to, step) result(res)
+    integer, intent(in) :: from, to, step
+    integer :: i
+    integer :: res
+
+    res = 0
+    do i = from, to, step
+      res = res + 1
+    end do
+  end function test_i
+
+  function test_r (from, to, step) result(res)
+    real, intent(in) :: from, to, step
+    real :: i
+    integer :: res
+
+    res = 0
+    do i = from, to, step
+      res = res + 1
+    end do
+  end function test_r
+
+end program test