re PR fortran/68196 (ICE on function result with procedure pointer component)

2015-11-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/68196
	* class.c (has_finalizer_component): Prevent infinite recursion
	through this function if the derived type and that of its
	component are the same.
	* trans-types.c (gfc_get_derived_type): Do the same for proc
	pointers by ignoring the explicit interface for the component.

	PR fortran/66465
	* check.c (same_type_check): If either of the expressions is
	BT_PROCEDURE, use the typespec from the symbol, rather than the
	expression.

2015-11-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/68196
	* gfortran.dg/proc_ptr_47.f90: New test.

	PR fortran/66465
	* gfortran.dg/pr66465.f90: New test.

From-SVN: r229954

gcc/fortran/ChangeLog

+2015-11-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/68196
+	* class.c (has_finalizer_component): Prevent infinite recursion
+	through this function if the derived type and that of its
+	component are the same.
+	* trans-types.c (gfc_get_derived_type): Do the same for proc
+	pointers by ignoring the explicit interface for the component.
+
+	PR fortran/66465
+	* check.c (same_type_check): If either of the expressions is
+	BT_PROCEDURE, use the typespec from the symbol, rather than the
+	expression.
+
 2015-11-07  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/68153
@@ -111,7 +125,7 @@
 
 	PR fortran/68154
 	* decl.c (add_init_expr_to_sym): if the char length in the typespec
-	is NULL, check for and use a constructor. 
+	is NULL, check for and use a constructor.
 
 2015-10-30  Steven G. Kargl  <kargl@gcc.gnu.org>
 

gcc/fortran/check.c

@@ -399,7 +399,15 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
 static bool
 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
 {
-  if (gfc_compare_types (&e->ts, &f->ts))
+  gfc_typespec *ets = &e->ts;
+  gfc_typespec *fts = &f->ts;
+
+  if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
+    ets = &e->symtree->n.sym->ts;
+  if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
+    fts = &f->symtree->n.sym->ts;
+
+  if (gfc_compare_types (ets, fts))
     return true;
 
   gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "

gcc/fortran/class.c

@@ -843,7 +843,11 @@ has_finalizer_component (gfc_symbol *derived)
 	  && c->ts.u.derived->f2k_derived->finalizers)
 	return true;
 
+      /* Stop infinite recursion through this function by inhibiting
+	 calls when the derived type and that of the component are
+	 the same.  */
       if (c->ts.type == BT_DERIVED
+	  && !gfc_compare_derived_types (derived, c->ts.u.derived)
 	  && !c->attr.pointer && !c->attr.allocatable
 	  && has_finalizer_component (c->ts.u.derived))
 	return true;

gcc/fortran/trans-types.c

@@ -2366,6 +2366,7 @@ gfc_get_derived_type (gfc_symbol * derived)
   gfc_component *c;
   gfc_dt_list *dt;
   gfc_namespace *ns;
+  tree tmp;
 
   if (derived->attr.unlimited_polymorphic
       || (flag_coarray == GFC_FCOARRAY_LIB
@@ -2517,8 +2518,19 @@ gfc_get_derived_type (gfc_symbol * derived)
      node as DECL_CONTEXT of each FIELD_DECL.  */
   for (c = derived->components; c; c = c->next)
     {
-      if (c->attr.proc_pointer)
+      /* Prevent infinite recursion, when the procedure pointer type is
+	 the same as derived, by forcing the procedure pointer component to
+	 be built as if the explicit interface does not exist.  */
+      if (c->attr.proc_pointer
+	  && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
+	       || (c->ts.u.derived
+		   && !gfc_compare_derived_types (derived, c->ts.u.derived))))
 	field_type = gfc_get_ppc_type (c);
+      else if (c->attr.proc_pointer && derived->backend_decl)
+	{
+	  tmp = build_function_type_list (derived->backend_decl, NULL_TREE);
+	  field_type = build_pointer_type (tmp);
+	}
       else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
         field_type = c->ts.u.derived->backend_decl;
       else

gcc/testsuite/ChangeLog

+2015-11-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/68196
+	* gfortran.dg/proc_ptr_47.f90: New test.
+
+	PR fortran/66465
+	* gfortran.dg/pr66465.f90: New test.
+
 2015-11-07  John David Anglin  <danglin@gcc.gnu.org>
 
 	* gcc.dg/Wno-frame-address.c: Skip on hppa*-*-*.
@@ -36,7 +44,7 @@
 2015-11-06  Dominique d'Humieres <dominiq@lps.ens.fr>
 
 	PR fortran/54224
-	* gfortran.dg/warn_unused_function_2.f90: Add two new 
+	* gfortran.dg/warn_unused_function_2.f90: Add two new
 	"defined but not used" subroutines.
 
 2015-11-06  Jakub Jelinek  <jakub@redhat.com>

gcc/testsuite/gfortran.dg/pr66465.f90

+! { dg-do compile }
+!
+! Tests the fix for PR66465, in which the arguments of the call to
+! ASSOCIATED were falsly detected to have different type/kind.
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+  interface
+     real function HandlerInterface (arg)
+       real :: arg
+     end
+  end interface
+
+  type TextHandlerTestCase
+     procedure (HandlerInterface), nopass, pointer :: handlerOut=>null()
+  end type
+
+  type(TextHandlerTestCase) this
+
+  procedure (HandlerInterface), pointer :: procPtr=>null()
+
+  print*, associated(procPtr, this%handlerOut)
+end

gcc/testsuite/gfortran.dg/proc_ptr_47.f90

+! { dg-do run }
+! Tests the fix for PR68196
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+  type AA
+    integer :: i
+    procedure(foo), pointer :: funct
+  end type
+  class(AA), allocatable :: my_AA
+  type(AA) :: res
+
+  allocate (my_AA, source = AA (1, foo))
+
+  res = my_AA%funct ()
+
+  if (res%i .ne. 3) call abort
+  if (.not.associated (res%funct)) call abort
+  if (my_AA%i .ne. 4) call abort
+  if (associated (my_AA%funct)) call abort
+
+contains
+  function foo(A)
+    class(AA), allocatable :: A
+    type(AA) foo
+
+    if (.not.allocated (A)) then
+      allocate (A, source = AA (2, foo))
+    endif
+
+    select type (A)
+      type is (AA)
+        foo = AA (3, foo)
+        A = AA (4, NULL ())
+    end select
+  end function
+end