From 43998ed92e06a48a1d52a37536fcc609ab2a608d Mon Sep 17 00:00:00 2001
From: Tobias Burnus <burnus@gcc.gnu.org>
Date: Sat, 28 Mar 2009 15:04:14 +0100
Subject: [PATCH] re PR fortran/32626 (Run-time check for recursive functions)
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.
From-SVN: r145188
---
gcc/fortran/ChangeLog | 13 ++++--
gcc/fortran/invoke.texi | 4 ++
gcc/fortran/options.c | 4 +-
gcc/fortran/trans-decl.c | 20 ++++++++++
gcc/testsuite/ChangeLog | 7 +++-
.../gfortran.dg/recursive_check_7.f90 | 40 +++++++++++++++++++
6 files changed, 82 insertions(+), 6 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/recursive_check_7.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e3bacc1aa0f6..5373c9df08eb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+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
@@ -8,12 +15,12 @@
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>
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 87afe783d6b4..9eb5de1a05c9 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -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
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 5daa73625044..fd9fb880d83c 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-decl.c b/gcc/fortran/trans-decl.c
index d3895d8cef00..6cfc86a4bb7d 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 315f6cfc06ff..aba092f9695f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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
index 000000000000..c1af8adc8102
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_check_7.f90
@@ -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'" }
--
GitLab