2009-08-18 Janus Weil <janus@gcc.gnu.org>

	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40870
	* trans-types.c (gfc_get_ppc_type): Include formal args in backend_decl
	using the interface symbol. Character types are returned by reference.
	(gfc_get_derived_type): Prevent infinite recursion loop
	if a PPC has a derived-type formal arg.

2009-08-18  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40870
	* gfortran.dg/proc_ptr_comp_13.f90: Extended.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cf5b4ec..d787326 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2009-08-18  Janus Weil  <janus@gcc.gnu.org>
+           Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/40870
+       * trans-types.c (gfc_get_ppc_type): Include formal args in backend_decl
+       using the interface symbol. Character types are returned by reference.
+       (gfc_get_derived_type): Prevent infinite recursion loop
+       if a PPC has a derived-type formal arg.
+
 2008-08-17  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/41062

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 8cc63c2..90e82d4 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1895,16 +1895,17 @@ tree
 gfc_get_ppc_type (gfc_component* c)
 {
   tree t;
-  if (c->attr.function && !c->attr.dimension)
-    {
-      if (c->ts.type == BT_DERIVED)
-       t = c->ts.u.derived->backend_decl;
-      else
-       t = gfc_typenode_for_spec (&c->ts);
-    }
+
+  /* Explicit interface.  */
+  if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
+    return build_pointer_type (gfc_get_function_type (c->ts.interface));
+
+  /* Implicit interface (only return value may be known).  */
+  if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
+    t = gfc_typenode_for_spec (&c->ts);
   else
     t = void_type_node;
-  /* TODO: Build argument list.  */
+
   return build_pointer_type (build_function_type (t, NULL_TREE));
 }
 
@@ -2012,8 +2013,11 @@ gfc_get_derived_type (gfc_symbol * derived)
      components' backend_decl may have not been built.  */
   if (derived->backend_decl)
     {
-      /* Its components' backend_decl have been built.  */
-      if (TYPE_FIELDS (derived->backend_decl))
+      /* Its components' backend_decl have been built or we are
+        seeing recursion through the formal arglist of a procedure
+        pointer component.  */
+      if (TYPE_FIELDS (derived->backend_decl)
+           || derived->attr.proc_pointer_comp)
         return derived->backend_decl;
       else
         typenode = derived->backend_decl;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 464e14c..c0d4923 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2009-08-18  Janus Weil  <janus@gcc.gnu.org>
+           Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/40870
+       * gfortran.dg/proc_ptr_comp_13.f90: Extended.
+
 2009-08-18  Richard Guenther  <rguenther@suse.de>
 
        PR middle-end/41094

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_13.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_13.f90
index 45ffa1e..afc8f55 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_13.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_13.f90
@@ -1,6 +1,7 @@
 ! { dg-do run }
 !
-! PR 40882: [F03] infinite recursion in gfc_get_derived_type with PPC returning derived type
+! PR 40882: [F03] infinite recursion in gfc_get_derived_type with PPC returning derived type.
+! At the same time, check that a formal argument does not cause infinite recursion (PR 40870).
 !
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
 
@@ -9,6 +10,7 @@ implicit none
 type :: t
   integer :: data
   procedure(foo), pointer, nopass :: ppc
+  procedure(type(t)), pointer, nopass :: ppc2
 end type
 
 type(t) :: o,o2
@@ -16,7 +18,7 @@ type(t) :: o,o2
 o%data = 1
 o%ppc => foo
 
-o2 = o%ppc()
+o2 = o%ppc(o)
 
 if (o%data /= 1) call abort()
 if (o2%data /= 5) call abort()
@@ -25,9 +27,9 @@ if (associated(o2%ppc)) call abort()
 
 contains
 
-  function foo()
-    type(t) :: foo
-    foo%data = 5
+  function foo(arg)
+    type(t) :: foo, arg
+    foo%data = arg%data * 5
     foo%ppc => NULL()
   end function