From: Janus Weil <janus@gcc.gnu.org>
Date: Mon, 29 Aug 2011 21:55:10 +0000 (+0200)
Subject: re PR fortran/50225 ([OOP] The allocation status for polymorphic allocatable function... 
X-Git-Tag: releases/gcc-4.7.0~4136
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=7a3eeb8555b6c14ccb9cd6b45ae0257da966fa07;p=thirdparty%2Fgcc.git

re PR fortran/50225 ([OOP] The allocation status for polymorphic allocatable function results is not set properly)

2011-08-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/50225
	* trans-decl.c (gfc_generate_function_code): Nullify polymorphic
	allocatable function results.

2011-08-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/50225
	* gfortran.dg/class_result_1.f03: New.

From-SVN: r178262
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a00723ea8261..d47e4115582f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2011-08-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50225
+	* trans-decl.c (gfc_generate_function_code): Nullify polymorphic
+	allocatable function results.
+
 2011-08-29  Tobias Burnus  <burnus@net-b.de>
 
 	* trans-decl.c (generate_coarray_sym_init): Use
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index ead8acf20b22..44363c298ae0 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5215,17 +5215,25 @@ gfc_generate_function_code (gfc_namespace * ns)
     {
       tree result = get_proc_result (sym);
 
-      if (result != NULL_TREE
-	    && sym->attr.function
-	    && !sym->attr.pointer)
+      if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
 	{
 	  if (sym->attr.allocatable && sym->attr.dimension == 0
 	      && sym->result == sym)
 	    gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
 							 null_pointer_node));
+	  else if (sym->ts.type == BT_CLASS
+		   && CLASS_DATA (sym)->attr.allocatable
+		   && sym->attr.dimension == 0 && sym->result == sym)
+	    {
+	      tmp = CLASS_DATA (sym)->backend_decl;
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (tmp), result, tmp, NULL_TREE);
+	      gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
+							null_pointer_node));
+	    }
 	  else if (sym->ts.type == BT_DERIVED
-	      && sym->ts.u.derived->attr.alloc_comp
-	      && !sym->attr.allocatable)
+		   && sym->ts.u.derived->attr.alloc_comp
+		   && !sym->attr.allocatable)
 	    {
 	      rank = sym->as ? sym->as->rank : 0;
 	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 238fc80d200b..18b19adc5814 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/50225
+	* gfortran.dg/class_result_1.f03: New.
+
 2011-08-29  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/48722
diff --git a/gcc/testsuite/gfortran.dg/class_result_1.f03 b/gcc/testsuite/gfortran.dg/class_result_1.f03
new file mode 100644
index 000000000000..f1f542bb1219
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_result_1.f03
@@ -0,0 +1,62 @@
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! PR 50225: [OOP] The allocation status for polymorphic allocatable function results is not set properly
+!
+! Contributed by Arjen Markus <arjen.markus895@gmail.com>
+
+module points2d
+
+  implicit none
+
+  type point2d
+      real :: x, y
+  end type
+
+contains
+
+ subroutine print( point )
+   class(point2d) :: point
+   write(*,'(2f10.4)') point%x, point%y
+ end subroutine
+
+ subroutine random_vector( point )
+   class(point2d) :: point
+   call random_number( point%x )
+   call random_number( point%y )
+   point%x = 2.0 * (point%x - 0.5)
+   point%y = 2.0 * (point%y - 0.5)
+ end subroutine
+
+ function add_vector( point, vector )
+   class(point2d), intent(in)  :: point, vector
+   class(point2d), allocatable :: add_vector
+   allocate( add_vector )
+   add_vector%x = point%x + vector%x
+   add_vector%y = point%y + vector%y
+ end function
+
+end module points2d
+
+
+program random_walk
+
+  use points2d
+  implicit none
+
+  type(point2d), target   :: point_2d, vector_2d
+  class(point2d), pointer :: point, vector
+  integer :: i
+
+  point  => point_2d
+  vector => vector_2d
+
+  do i=1,2
+    call random_vector(point)
+    call random_vector(vector)
+    call print(add_vector(point, vector))
+  end do
+
+end program random_walk
+
+! { dg-final { cleanup-modules "points2d" } }