Patchwork [Fortran] PR51514 - fix passing a CLASS to a TYPE

login
register
mail settings
Submitter Tobias Burnus
Date Feb. 6, 2012, 10:27 p.m.
Message ID <4F3053B9.2080302@net-b.de>
Download mbox | patch
Permalink /patch/139816/
State New
Headers show

Comments

Tobias Burnus - Feb. 6, 2012, 10:27 p.m.
When passing a CLASS to a TYPE, the "_data" component wasn't added for 
scalar variables. (Polymorphic arrays are/were handled correctly.)

This patch adds the _data, fixing this wrong-code issue.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
Paul Richard Thomas - Feb. 7, 2012, 6:08 a.m.
Dear Tobias,

On Mon, Feb 6, 2012 at 11:27 PM, Tobias Burnus <burnus@net-b.de> wrote:
> When passing a CLASS to a TYPE, the "_data" component wasn't added for
> scalar variables. (Polymorphic arrays are/were handled correctly.)
>
> This patch adds the _data, fixing this wrong-code issue.
>
> Build and regtested on x86-64-linux.
> OK for the trunk?

I cannot think how I have not encountered this in the tests of the
last few months - perhaps, I have been too class-centric?

OK for trunk

Thanks for the patch.

Paul

Patch

2012-02-06  Tobias Burnus  <burnus@net-b.de>

	PR fortran/51514
	* trans-expr.c (gfc_conv_procedure_call): Add _data component
	for calls of scalar CLASS actuals to TYPE dummies.

2012-02-06  Tobias Burnus  <burnus@net-b.de>

	PR fortran/51514
	* gfortran.dg/class_to_type_2.f90: New.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 183942)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -3619,6 +3619,12 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
 			&& CLASS_DATA (e)->attr.dimension)
 		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
 
+		  if (fsym && fsym->ts.type == BT_DERIVED
+		      && e->ts.type == BT_CLASS
+		      && !CLASS_DATA (e)->attr.dimension
+		      && !CLASS_DATA (e)->attr.codimension)
+		    parmse.expr = gfc_class_data_get (parmse.expr);
+
 		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
 		     allocated on entry, it must be deallocated.  */
 		  if (fsym && fsym->attr.allocatable
Index: gcc/testsuite/gfortran.dg/class_to_type_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_to_type_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/class_to_type_2.f90	(Arbeitskopie)
@@ -0,0 +1,97 @@ 
+! { dg-do run }
+!
+! PR fortran/51514
+!
+! Check that passing a CLASS to a TYPE works
+!
+! Based on a test case of Reinhold Bader.
+!
+
+module mod_subpr
+  implicit none
+
+  type :: foo
+    integer :: i = 2
+  end type
+
+  type, extends(foo) :: foo_1
+    real :: r(2)
+  end type
+
+contains
+
+  subroutine subpr (x)
+    type(foo) :: x
+    x%i = 3
+  end subroutine
+
+  elemental subroutine subpr_elem (x)
+    type(foo), intent(inout):: x
+    x%i = 3
+  end subroutine
+
+  subroutine subpr_array (x)
+    type(foo), intent(inout):: x(:)
+    x(:)%i = 3
+  end subroutine
+
+  subroutine subpr2 (x)
+    type(foo) :: x
+    if (x%i /= 55) call abort ()
+  end subroutine
+
+  subroutine subpr2_array (x)
+    type(foo) :: x(:)
+    if (any(x(:)%i /= 55)) call abort ()
+  end subroutine
+
+  function f ()
+    class(foo), allocatable :: f
+    allocate (f)
+    f%i = 55
+  end function f
+
+  function g () result(res)
+    class(foo), allocatable :: res(:)
+    allocate (res(3))
+    res(:)%i = 55
+  end function g
+end module
+
+program prog
+  use mod_subpr
+  implicit none
+  class(foo), allocatable :: xx, yy(:)
+
+  allocate (foo_1 :: xx)
+  xx%i = 33
+  call subpr (xx)
+  if (xx%i /= 3) call abort ()
+
+  xx%i = 33
+  call subpr_elem (xx)
+  if (xx%i /= 3) call abort ()
+
+  call subpr (f ())
+
+  allocate (foo_1 :: yy(2))
+  yy(:)%i = 33
+  call subpr_elem (yy)
+  if (any (yy%i /= 3)) call abort ()
+
+  yy(:)%i = 33
+  call subpr_elem (yy(1))
+  if (yy(1)%i /= 3) call abort ()
+
+  yy(:)%i = 33
+  call subpr_array (yy)
+  if (any (yy%i /= 3)) call abort ()
+
+  yy(:)%i = 33
+  call subpr_array (yy(1:2))
+  if (any (yy(1:2)%i /= 3)) call abort ()
+
+ call subpr2_array (g ())
+end program
+
+! { dg-final { cleanup-modules "mod_subpr" } }