re PR fortran/37779 (Missing RECURSIVE not detected)

2008-11-24  Daniel Kraft  <d@domob.eu>

	PR fortran/37779
	* resolve.c (resolve_procedure_expression): New method.
	(resolve_variable): Call it.
	(resolve_actual_arglist): Call gfc_resolve_expr for procedure arguments.

2008-11-24  Daniel Kraft  <d@domob.eu>

	PR fortran/37779
	* gfortran.dg/c_funloc_tests.f03: Added missing `RECURSIVE'.
	* gfortran.dg/c_funloc_tests_2.f03: Ditto.
	* gfortran.dg/recursive_check_4.f03: New test.
	* gfortran.dg/recursive_check_5.f03: New test.

From-SVN: r142158

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5f55609e6caadc4f1db73a2b11a04671b9fd17c5..8a0092175ee15f91a41f262b9ede225cd3ee0bbf 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2008-11-24  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/37779
+       * resolve.c (resolve_procedure_expression): New method.
+       (resolve_variable): Call it.
+       (resolve_actual_arglist): Call gfc_resolve_expr for procedure arguments.
+
 2008-11-24  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/34820

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0f0644f0d83417c391f348006318c96f52eef397..f1c27e62b59a1d63f9557af6970b32e666e92aca 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1072,6 +1072,33 @@ count_specific_procs (gfc_expr *e)
   return n;
 }
 
+
+/* Resolve a procedure expression, like passing it to a called procedure or as
+   RHS for a procedure pointer assignment.  */
+
+static gfc_try
+resolve_procedure_expression (gfc_expr* expr)
+{
+  gfc_symbol* sym;
+
+  if (expr->ts.type != BT_PROCEDURE || expr->expr_type != EXPR_VARIABLE)
+    return SUCCESS;
+  gcc_assert (expr->symtree);
+  sym = expr->symtree->n.sym;
+  gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+  /* A non-RECURSIVE procedure that is used as procedure expression within its
+     own body is in danger of being called recursively.  */
+  if (!sym->attr.recursive && sym == gfc_current_ns->proc_name
+      && !gfc_option.flag_recursive)
+    gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
+                " itself recursively.  Declare it RECURSIVE or use"
+                " -frecursive", sym->name, &expr->where);
+  
+  return SUCCESS;
+}
+
+
 /* Resolve an actual argument list.  Most of the time, this is just
    resolving the expressions in the list.
    The exception is that we sometimes have to decide whether arguments
@@ -1180,8 +1207,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
                && sym->ns == gfc_current_ns
                && !sym->ns->entries->sym->attr.recursive)
            {
-             gfc_error ("Reference to ENTRY '%s' at %L is recursive, but procedure "
-                        "'%s' is not declared as RECURSIVE",
+             gfc_error ("Reference to ENTRY '%s' at %L is recursive, but"
+                        " procedure '%s' is not declared as RECURSIVE",
                         sym->name, &e->where, sym->ns->entries->sym->name);
            }
 
@@ -1211,6 +1238,9 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
              sym->attr.intrinsic = 1;
              sym->attr.function = 1;
            }
+
+         if (gfc_resolve_expr (e) == FAILURE)
+           return FAILURE;
          goto argument_list;
        }
 
@@ -1235,6 +1265,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
          || sym->attr.intrinsic
          || sym->attr.external)
        {
+         if (gfc_resolve_expr (e) == FAILURE)
+           return FAILURE;
          goto argument_list;
        }
 
@@ -4155,7 +4187,7 @@ resolve_variable (gfc_expr *e)
   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     {
       e->ts.type = BT_PROCEDURE;
-      return SUCCESS;
+      goto resolve_procedure;
     }
 
   if (sym->ts.type != BT_UNKNOWN)
@@ -4237,6 +4269,10 @@ resolve_variable (gfc_expr *e)
        sym->entry_id = current_entry_id + 1;
     }
 
+resolve_procedure:
+  if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
+    t = FAILURE;
+
   return t;
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 734759df2a5506dc05bf4217d8629d26c477574e..d66b4eba18c797ac45adc3eeaca7769cd3037e84 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2008-11-24  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/37779
+       * gfortran.dg/c_funloc_tests.f03: Added missing `RECURSIVE'.
+       * gfortran.dg/c_funloc_tests_2.f03: Ditto.
+       * gfortran.dg/recursive_check_4.f03: New test.
+       * gfortran.dg/recursive_check_5.f03: New test.
+
 2008-11-24  Mikael Morin <mikael.morin@tele2.fr>
 
        PR fortran/35681

diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests.f03
index c34ef2b6f4948311985e9944a01437ff2af80818..8ba07b9fbba10635d0a7495dfd33ce11bd8668c7 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c_funloc_tests.f03
+++ b/gcc/testsuite/gfortran.dg/c_funloc_tests.f03
@@ -5,7 +5,7 @@ module c_funloc_tests
   use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
 
 contains
-  subroutine sub0() bind(c)
+  recursive subroutine sub0() bind(c)
     type(c_funptr) :: my_c_funptr
 
     my_c_funptr = c_funloc(sub0)

diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
index afaf29fc896aeb99319d2f08d9dd773d42364602..d3ed265ea8c3f7744f91f9150e9842a04d3178b5 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
+++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
@@ -4,7 +4,7 @@ module c_funloc_tests_2
   implicit none
 
 contains
-  subroutine sub0() bind(c)
+  recursive subroutine sub0() bind(c)
     type(c_funptr) :: my_c_funptr
     integer :: my_local_variable
     

diff --git a/gcc/testsuite/gfortran.dg/recursive_check_4.f03 b/gcc/testsuite/gfortran.dg/recursive_check_4.f03
new file mode 100644 (file)
index 0000000..2a95554
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_check_4.f03
@@ -0,0 +1,26 @@
+! { dg-do compile }
+
+! PR fortran/37779
+! Check that using a non-recursive procedure as "value" is an error.
+
+MODULE m
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE test ()
+    IMPLICIT NONE
+    PROCEDURE(test), POINTER :: procptr
+
+    CALL bar (test) ! { dg-warning "Non-RECURSIVE" }
+    procptr => test ! { dg-warning "Non-RECURSIVE" }
+  END SUBROUTINE test
+
+  INTEGER FUNCTION func ()
+    ! Using a result variable is ok of course!
+    func = 42 ! { dg-bogus "Non-RECURSIVE" }
+  END FUNCTION func
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }

diff --git a/gcc/testsuite/gfortran.dg/recursive_check_5.f03 b/gcc/testsuite/gfortran.dg/recursive_check_5.f03
new file mode 100644 (file)
index 0000000..4014986
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/recursive_check_5.f03
@@ -0,0 +1,27 @@
+! { dg-do compile }
+! { dg-options "-frecursive" }
+
+! PR fortran/37779
+! Check that -frecursive allows using procedures in as procedure expressions.
+
+MODULE m
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE test ()
+    IMPLICIT NONE
+    PROCEDURE(test), POINTER :: procptr
+
+    CALL bar (test) ! { dg-bogus "Non-RECURSIVE" }
+    procptr => test ! { dg-bogus "Non-RECURSIVE" }
+  END SUBROUTINE test
+
+  INTEGER FUNCTION func ()
+    ! Using a result variable is ok of course!
+    func = 42 ! { dg-bogus "Non-RECURSIVE" }
+  END FUNCTION func
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }