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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fc3afba3aaf1e7c43bea4233ac6a5857aeaff4a4..ce3d7d03410deb8afb8ed6ab33fa26e91ccf7049 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+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>
 

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 86dae5b000c46020b72110bad649613d672feadd..038ee218d9450207301ace67386bec1d785eae9f 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 ("%qs argument of %qs intrinsic at %L must be the same type "

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 7a9e2755a0fd87487006cce3e6894630ae7ba6a0..8b49ae95a2069cfb05786a33b1932efa4725f6c5 100644 (file)
--- a/gcc/fortran/class.c
+++ b/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;

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 780200e5f5d9a557a3e9c29c8e255a81bfc29222..ad6cee876069107b192e04505151b206f40976e8 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7cc0ac9d3be91d90d24843a85b746d3c6a6f220b..2801c946fe7171180b057a225a56373ee5a313c0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+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>

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