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

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

	Backport from trunk.
	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-25  Paul Thomas  <pault@gcc.gnu.org>

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

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

From-SVN: r230852

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 337bd32eaf8733ceeafd522e3a968a22a34ad65c..33270a1c24fb5eb89bfd9674945cdedbac00f3e8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2015-11-25  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from trunk.
+       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.
+
 2013-10-19  Paul Thomas  <pault@gcc.gnu.org>
 
        Backport from trunk

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index b83d9da148db1710d059b538addd9e5ca0087f18..07cacd048fc4869b6518390e88b9b10b11a1bd60 100644 (file)
--- a/gcc/fortran/check.c
+++ b/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 ("'%s' argument of '%s' intrinsic at %L must be the same type "

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index f83a24bd1b002a9170a4078502b9f7c0abd6c53b..32ddb6e34f7f5db1fae520d348c565ebfb10b45d 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -840,7 +840,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;

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 20069e239ccc088a13371b565274b2295c39d297..26db35fb8f5cc70495835933da7354efcc006324 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2342,6 +2342,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)
     return ptr_type_node;
@@ -2490,8 +2491,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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 04a458433e7cfd6cb20525ba0343d0aa174c7568..c2ba540f25dde893c9512ec9df845ddb210a4b4b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+2015-11-25  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from trunk.
+       PR fortran/68196
+       * gfortran.dg/proc_ptr_47.f90: New test.
+
+       Backport from trunk.
+       PR fortran/66465
+       * gfortran.dg/pr66465.f90: New test.
+
 2015-11-24  Kyrylo Tkachov  <kyrylo.tkachov@arm.com>
 
        Backport from mainline

diff --git a/gcc/testsuite/gfortran.dg/pr66465.f90 b/gcc/testsuite/gfortran.dg/pr66465.f90
new file mode 100644 (file)
index 0000000..ab86830
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr66465.f90
@@ -0,0 +1,23 @@
+! { 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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
new file mode 100644 (file)
index 0000000..43084f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
@@ -0,0 +1,37 @@
+! { 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