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

gcc/fortran/ChangeLog

+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

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;
 }
 

gcc/testsuite/ChangeLog

+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

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)

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
     

gcc/testsuite/gfortran.dg/recursive_check_4.f03

+! { 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" } }

gcc/testsuite/gfortran.dg/recursive_check_5.f03

+! { 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" } }