OSDN Git Service

2009-03-28 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 28 Mar 2009 14:04:14 +0000 (14:04 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 28 Mar 2009 14:04:14 +0000 (14:04 +0000)
        PR fortran/32626
        * option.c (gfc_handle_runtime_check_option): Enable recursion check.
        * trans-decl.c (gfc_generate_function_code): Add recursion check.
        * invoke.texi (-fcheck): Add recursive option.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@145188 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/invoke.texi
gcc/fortran/options.c
gcc/fortran/trans-decl.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/recursive_check_7.f90 [new file with mode: 0644]

index e3bacc1..5373c9d 100644 (file)
@@ -1,5 +1,12 @@
 2009-03-28  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/32626
+       * option.c (gfc_handle_runtime_check_option): Enable recursion check.
+       * trans-decl.c (gfc_generate_function_code): Add recursion check.
+       * invoke.texi (-fcheck): Add recursive option.
+
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
        PR fortran/38432
        * resolve.c (gfc_resolve_iterator): Add zero-loop warning.
 
            Tobias Burnus  <burnus@net-b.de>
 
        * gfortran.h (gfc_option_t): Add rtcheck.
-       * lang.opt: New option -fruntime-check.
+       * lang.opt: New option -fcheck.
        * libgfortran.h: Add GFC_RTCHECK_* constants.
-       * invoke.texi: Document -fruntime-check.
+       * invoke.texi: Document -fcheck.
        * options.c (gfc_handle_runtime_check_option): New function.
        (gfc_init_options,gfc_post_options,gfc_handle_option):
-       Add -fruntime-check option.
+       Add -fcheck option.
 
 2009-03-27  Richard Guenther  <rguenther@suse.de>
 
index 87afe78..9eb5de1 100644 (file)
@@ -1220,6 +1220,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{recursion}
+Enable generation of run-time checks for recursively called subroutines and
+functions which are not marked as recursive. See also @option{-frecursive}.
 @end table
 
 
index 5daa736..fd9fb88 100644 (file)
@@ -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)
index d3895d8..6cfc86a 100644 (file)
@@ -3679,6 +3679,7 @@ gfc_generate_function_code (gfc_namespace * ns)
   stmtblock_t block;
   stmtblock_t body;
   tree result;
+  tree recurcheckvar = NULL;
   gfc_symbol *sym;
   int rank;
 
@@ -3846,6 +3847,22 @@ gfc_generate_function_code (gfc_namespace * ns)
       gfc_add_expr_to_block (&body, tmp);
     }
 
+   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !sym->attr.recursive)
+     {
+       char * msg;
+
+       asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+                sym->name);
+       recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+       TREE_STATIC (recurcheckvar) = 1;
+       DECL_INITIAL (recurcheckvar) = boolean_false_node;
+       gfc_add_expr_to_block (&block, recurcheckvar);
+       gfc_trans_runtime_check (true, false, recurcheckvar, &block,
+                               &sym->declared_at, msg);
+       gfc_add_modify (&block, recurcheckvar, boolean_true_node);
+       gfc_free (msg);
+    }
+
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
       && sym->attr.subroutine)
     {
@@ -3924,6 +3941,9 @@ gfc_generate_function_code (gfc_namespace * ns)
   else
     gfc_add_expr_to_block (&block, tmp);
 
+ /* Reset recursion-check variable.  */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !sym->attr.recursive)
+   gfc_add_modify (&block, recurcheckvar, boolean_false_node);
 
   /* Add all the decls we created during processing.  */
   decl = saved_function_decls;
index 315f6cf..aba092f 100644 (file)
@@ -1,4 +1,9 @@
-2009-03-28 Tobias Burnus  <burnus@net-b.de>
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/32626
+       * gfortran.dg/recursive_check_7.f90: New test.
+
+2009-03-28  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/38432
        * gfortran.dg/do_check_5.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/recursive_check_7.f90 b/gcc/testsuite/gfortran.dg/recursive_check_7.f90
new file mode 100644 (file)
index 0000000..c1af8ad
--- /dev/null
@@ -0,0 +1,40 @@
+! { dg-do run }
+! { dg-options "-fcheck=recursion" }
+! { dg-shouldfail "Recursion check" }
+!
+! PR fortran/32626
+! Recursion run-time check
+!
+
+subroutine NormalFunc()
+end subroutine NormalFunc
+
+recursive subroutine valid(x)
+  logical :: x
+  if(x) call sndValid()
+  print *, 'OK'
+end subroutine valid
+
+subroutine sndValid()
+  call valid(.false.)
+end subroutine sndValid
+
+subroutine invalid(x)
+  logical :: x
+  if(x) call sndInvalid()
+  print *, 'BUG'
+  call abort()
+end subroutine invalid
+
+subroutine sndInvalid()
+  call invalid(.false.)
+end subroutine sndInvalid
+
+call valid(.true.)
+call valid(.true.)
+call NormalFunc()
+call NormalFunc()
+call invalid(.true.)
+end
+
+! { dg-output "Fortran runtime error: Recursive call to nonrecursive procedure 'invalid'" }