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

2015-12-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/68196
	*expr.c (gfc_has_default_initializer): Prevent infinite recursion
	through this function for procedure pointer components.
	* trans-array.c (structure_alloc_comps): Ditto twice.

2015-12-18  Paul Thomas  <pault@gcc.gnu.org>

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

From-SVN: r231807

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 27dc78c..eeb79d9 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2015-12-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/68196
+       *expr.c (gfc_has_default_initializer): Prevent infinite recursion
+       through this function for procedure pointer components.
+       * trans-array.c (structure_alloc_comps): Ditto twice.
+
 2015-12-15  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
 
        * resolve.c (resolve_critical): Committing symbols of

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 5dd90ef..5d7bcee 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3930,7 +3930,7 @@ gfc_has_default_initializer (gfc_symbol *der)
   for (c = der->components; c; c = c->next)
     if (c->ts.type == BT_DERIVED)
       {
-        if (!c->attr.pointer
+        if (!c->attr.pointer && !c->attr.proc_pointer
             && gfc_has_default_initializer (c->ts.u.derived))
          return true;
        if (c->attr.pointer && c->initializer)

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6e24e2e..71e0482 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8074,7 +8074,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
            }
 
          if (cmp_has_alloc_comps
-               && !c->attr.pointer
+               && !c->attr.pointer && !c->attr.proc_pointer
                && !called_dealloc_with_status)
            {
              /* Do not deallocate the components of ultimate pointer
@@ -8264,7 +8264,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
             components that are really allocated, the deep copy code has to
             be generated first and then added to the if-block in
             gfc_duplicate_allocatable ().  */
-         if (cmp_has_alloc_comps)
+         if (cmp_has_alloc_comps
+             && !c->attr.proc_pointer)
            {
              rank = c->as ? c->as->rank : 0;
              tmp = fold_convert (TREE_TYPE (dcmp), comp);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 319cec6..324f549 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-12-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/68196
+       * gfortran.dg/proc_ptr_48.f90: New test.
+
 2015-12-18  Andreas Krebbel  <krebbel@linux.vnet.ibm.com>
 
        * gcc.target/s390/hotpatch-8.c: Add -Wno-deprecated to options.
@@ -16,7 +21,7 @@
 2015-12-17  Nathan Sidwell  <nathan@acm.org>
 
        * gcc.dg/ipa/ipa-icf-merge-1.c: New.
-       
+
 2015-12-17  David Malcolm  <dmalcolm@redhat.com>
 
        * gcc.dg/diagnostic-range-bad-return.c: New test case.

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_48.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_48.f90
new file mode 100644 (file)
index 0000000..deed635
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_48.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+!
+! Checks the fix for PR68196, comment #8
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+  type  Bug                                  ! Failed at trans--array.c:8269
+    real, allocatable :: scalar
+    procedure(boogInterface),pointer :: boog
+  end type
+  interface
+    function boogInterface(A) result(C)
+      import Bug
+      class(Bug) A
+      type(Bug)  C
+    end function
+  end interface
+
+  real, parameter :: ninetynine = 99.0
+  real, parameter :: onenineeight = 198.0
+
+  type(bug) :: actual, res
+
+  actual%scalar = ninetynine
+  actual%boog => boogImplementation
+
+  res = actual%boog ()                       ! Failed on bug in expr.c:3933
+  if (res%scalar .ne. onenineeight) call abort
+
+! Make sure that the procedure pointer is assigned correctly
+  if (actual%scalar .ne. ninetynine) call abort
+  actual = res%boog ()
+  if (actual%scalar .ne. onenineeight) call abort
+
+! Deallocate so that we can use valgrind to check for memory leaks
+  deallocate (res%scalar, actual%scalar)
+
+contains
+    function boogImplementation(A) result(C) ! Failed at trans--array.c:8078
+      class(Bug) A
+      type(Bug)  C
+      select type (A)
+        type is (bug)
+          C = A
+          C%scalar = onenineeight
+        class default
+          call abort
+      end select
+    end function
+end