re PR fortran/34656 (modifies do loop variable)

2009-03-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34656
        * trans-stmt.c (gfc_trans_simple_do, gfc_trans_do):
        Add GFC_RTCHECK_DO support.
        * option.c (gfc_handle_runtime_check_option): Enable
        * GFC_RTCHECK_DO.
        * invoke.texi (-fcheck): Document "do" option.

From-SVN: r145210

9 files changed, 150 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 47ebdce..d063295 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,7 +1,15 @@
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34656
+	* trans-stmt.c (gfc_trans_simple_do, gfc_trans_do):
+	Add GFC_RTCHECK_DO support.
+	* option.c (gfc_handle_runtime_check_option): Enable GFC_RTCHECK_DO.
+	* invoke.texi (-fcheck): Document "do" option.
+
 2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
 
-        PR fortran/38538
-        * trans-array.c (get_elemental_fcn_charlen): Remove.
+	PR fortran/38538
+	* trans-array.c (get_elemental_fcn_charlen): Remove.
 	(get_array_charlen): New function to replace previous.
 
 2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 9eb5de1..a263a15 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -5,7 +5,7 @@
 
 @ignore
 @c man begin COPYRIGHT
-Copyright @copyright{} 2004, 2005, 2006, 2007, 2008
+Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009
 Free Software Foundation, Inc.
 
 Permission is granted to copy, distribute and/or modify this document
@@ -1221,6 +1221,10 @@ the compilation of the main program.
 Note: In the future this may also include other forms of checking, e.g.,
 checking substring references.
 
+@item @samp{do}
+Enable generation of run-time checks for invalid modification of loop
+iteration variables.
+
 @item @samp{recursion}
 Enable generation of run-time checks for recursively called subroutines and
 functions which are not marked as recursive. See also @option{-frecursive}.
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index fd9fb88..587fb36 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -458,10 +458,10 @@ gfc_handle_runtime_check_option (const char *arg)
 {
   int result, pos = 0, n;
   static const char * const optname[] = { "all", "bounds", "array-temps",
-					  "recursion", /* "do", */ NULL };
+					  "recursion", "do", NULL };
   static const int optmask[] = { GFC_RTCHECK_ALL, GFC_RTCHECK_BOUNDS,
 				 GFC_RTCHECK_ARRAY_TEMPS,
-				 GFC_RTCHECK_RECURSION, /* GFC_RTCHECK_DO, */
+				 GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO,
 				 0 };
  
   while (*arg)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 3937e2a..0e51bda 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -761,6 +761,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
   tree type;
   tree cond;
   tree tmp;
+  tree saved_dovar = NULL;
   tree cycle_label;
   tree exit_label;
   
@@ -768,6 +769,13 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
 
   /* Initialize the DO variable: dovar = from.  */
   gfc_add_modify (pblock, dovar, from);
+  
+  /* Save value for do-tinkering checking. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      saved_dovar = gfc_create_var (type, ".saved_dovar");
+      gfc_add_modify (pblock, saved_dovar, dovar);
+    }
 
   /* Cycle and exit statements are implemented with gotos.  */
   cycle_label = gfc_build_label_decl (NULL_TREE);
@@ -790,6 +798,14 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* Check whether someone has modified the loop variable. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      tmp = fold_build2 (NE_EXPR, boolean_type_node, dovar, saved_dovar);
+      gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
+			       "Loop variable has been modified");
+    }
+
   /* Evaluate the loop condition.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
   cond = gfc_evaluate_now (cond, &body);
@@ -798,6 +814,9 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
   tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
   gfc_add_modify (&body, dovar, tmp);
 
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    gfc_add_modify (&body, saved_dovar, dovar);
+
   /* The loop exit.  */
   tmp = build1_v (GOTO_EXPR, exit_label);
   TREE_USED (exit_label) = 1;
@@ -864,6 +883,7 @@ gfc_trans_do (gfc_code * code)
 {
   gfc_se se;
   tree dovar;
+  tree saved_dovar = NULL;
   tree from;
   tree to;
   tree step;
@@ -902,6 +922,14 @@ gfc_trans_do (gfc_code * code)
   gfc_add_block_to_block (&block, &se.pre);
   step = gfc_evaluate_now (se.expr, &block);
 
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      tmp = fold_build2 (EQ_EXPR, boolean_type_node, step,
+			 fold_convert (type, integer_zero_node));
+      gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
+			       "DO step value is zero");
+    }
+
   /* Special case simple loops.  */
   if (TREE_CODE (type) == INTEGER_TYPE
       && (integer_onep (step)
@@ -925,6 +953,13 @@ gfc_trans_do (gfc_code * code)
   /* Initialize the DO variable: dovar = from.  */
   gfc_add_modify (&block, dovar, from);
 
+  /* Save value for do-tinkering checking. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      saved_dovar = gfc_create_var (type, ".saved_dovar");
+      gfc_add_modify (&block, saved_dovar, dovar);
+    }
+
   /* Initialize loop count and jump to exit label if the loop is empty.
      This code is executed before we enter the loop body. We generate:
      if (step > 0)
@@ -1011,10 +1046,21 @@ gfc_trans_do (gfc_code * code)
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* Check whether someone has modified the loop variable. */
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    {
+      tmp = fold_build2 (NE_EXPR, boolean_type_node, dovar, saved_dovar);
+      gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
+			       "Loop variable has been modified");
+    }
+
   /* Increment the loop variable.  */
   tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
   gfc_add_modify (&body, dovar, tmp);
 
+  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
+    gfc_add_modify (&body, saved_dovar, dovar);
+
   /* End with the loop condition.  Loop until countm1 == 0.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node, countm1,
 		      build_int_cst (utype, 0));
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7a870c2..ee2e360 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34656
+	* gfortran.dg/do_check_1.f90: Add test.
+	* gfortran.dg/do_check_2.f90: Add test.
+	* gfortran.dg/do_check_3.f90: Add test.
+	* gfortran.dg/do_check_4.f90: Add test.
+
 2009-03-28  Jan Hubicka  <jh@suse.cz>
 
 	* gcc.dg/attr-noinline.c: Avoid pure-const optimization.
diff --git a/gcc/testsuite/gfortran.dg/do_check_1.f90 b/gcc/testsuite/gfortran.dg/do_check_1.f90
new file mode 100644
index 0000000..94d8a84
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_check_1.f90
@@ -0,0 +1,16 @@
+! { dg-do run }
+! { dg-options "-fcheck=do" }
+! { dg-shouldfail "DO check" }
+!
+! PR fortran/34656
+! Run-time check for zero STEP
+!
+program test
+  implicit none
+  integer :: i,j
+  j = 0
+  do i = 1, 40, j
+    print *, i
+  end do
+end program test
+! { dg-output "Fortran runtime error: DO step value is zero" }
diff --git a/gcc/testsuite/gfortran.dg/do_check_2.f90 b/gcc/testsuite/gfortran.dg/do_check_2.f90
new file mode 100644
index 0000000..c40760d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_check_2.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-fcheck=do" }
+! { dg-shouldfail "DO check" }
+!
+! PR fortran/34656
+! Run-time check for modifing loop variables
+!
+program test
+  implicit none
+  integer :: i,j
+  do i = 1, 10
+    call modLoopVar(i)
+  end do
+contains
+  subroutine modLoopVar(i)
+    integer :: i
+    i = i + 1
+  end subroutine modLoopVar
+end program test
+! { dg-output "Fortran runtime error: Loop variable has been modified" }
diff --git a/gcc/testsuite/gfortran.dg/do_check_3.f90 b/gcc/testsuite/gfortran.dg/do_check_3.f90
new file mode 100644
index 0000000..15086c2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_check_3.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-options "-fcheck=do" }
+! { dg-shouldfail "DO check" }
+!
+! PR fortran/34656
+! Run-time check for modifing loop variables
+!
+program test
+  implicit none
+  real :: i, j, k
+  j = 10.0
+  k = 1.0
+  do i = 1.0, j, k ! { dg-warning "must be integer" }
+    call modLoopVar(i)
+  end do
+contains
+  subroutine modLoopVar(x)
+    real :: x
+    x = x + 1
+  end subroutine modLoopVar
+end program test
+! { dg-output "Fortran runtime error: Loop variable has been modified" }
diff --git a/gcc/testsuite/gfortran.dg/do_check_4.f90 b/gcc/testsuite/gfortran.dg/do_check_4.f90
new file mode 100644
index 0000000..65bc92c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_check_4.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-fcheck=do" }
+! { dg-shouldfail "DO check" }
+!
+! PR fortran/34656
+! Run-time check for modifing loop variables
+!
+PROGRAM test
+  IMPLICIT NONE
+  INTEGER :: i
+  DO i=1,100
+    CALL do_something()
+  ENDDO
+CONTAINS
+ SUBROUTINE do_something()
+ IMPLICIT NONE
+   DO i=1,10
+   ENDDO
+ END SUBROUTINE do_something
+END PROGRAM test
+! { dg-output "Fortran runtime error: Loop variable has been modified" }