re PR fortran/50225 ([OOP] The allocation status for polymorphic allocatable function...

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 a00723e..d47e411 100644 (file)
--- 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 ead8acf..44363c2 100644 (file)
--- 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 238fc80..18b19ad 100644 (file)
--- 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 (file)
index 0000000..f1f542b
--- /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" } }