re PR fortran/55072 (Missing internal_pack leads to wrong code with derived type)

2013-01-14  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/55072
	* trans-array.c (gfc_conv_array_parameter): No packing was done for
	full arrays of derived type.

2013-01-14  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/55072
	* gfortran.dg/internal_pack_13.f90: New test.
	* gfortran.dg/internal_pack_14.f90: New test.

From-SVN: r195178

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 914e6d9ff12318e6d3fb8e9164c61c07930ee342..43776e7508cdc4008bf3eb175ad6c4119ea3e5b1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2013-01-14  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/55072
+       * trans-array.c (gfc_conv_array_parameter): No packing was done for
+       full arrays of derived type.
+
 2013-01-14  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/55618

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ce8985c23406af01c1abaa58308b3bdc7e2bbe9f..c3e993415ce9acc1373e2439508f7f3732f4356e 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6014,20 +6014,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
     this_array_result = false;
 
   /* Passing address of the array if it is not pointer or assumed-shape.  */
-  if (full_array_var && g77 && !this_array_result)
+  if (full_array_var && g77 && !this_array_result
+      && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
     {
       tmp = gfc_get_symbol_decl (sym);
 
       if (sym->ts.type == BT_CHARACTER)
        se->string_length = sym->ts.u.cl->backend_decl;
 
-      if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
-       {
-         gfc_conv_expr_descriptor (se, expr, ss);
-         se->expr = gfc_conv_array_data (se->expr);
-         return;
-       }
-
       if (!sym->attr.pointer
            && sym->as
            && sym->as->type != AS_ASSUMED_SHAPE 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index dc72437145164d4e14a82435c55d92e30f14c9ac..81664c64afdd134421c269efdd0beca4297172aa 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2013-01-14  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/55072
+       * gfortran.dg/internal_pack_13.f90: New test.
+       * gfortran.dg/internal_pack_14.f90: New test.
+
 2013-01-14  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/55618

diff --git a/gcc/testsuite/gfortran.dg/internal_pack_13.f90 b/gcc/testsuite/gfortran.dg/internal_pack_13.f90
new file mode 100644 (file)
index 0000000..21fdc54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/internal_pack_13.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+!
+! PR 55072: [4.6/4.7/4.8 Regression] Missing internal_pack leads to wrong code with derived type
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+type t
+integer :: i
+end type t
+type(t), target :: tgt(4,4)
+type(t), pointer :: p(:,:)
+integer :: i,j,k
+
+k = 1
+do i = 1, 4
+  do j = 1, 4
+    tgt(i,j)%i = k
+    k = k+1
+  end do
+end do
+
+p => tgt(::2,::2)
+print *,p%i
+call bar(p)
+
+contains
+
+  subroutine bar(x)
+    type(t) :: x(*)
+    print *,x(1:4)%i
+    if (any (x(1:4)%i /= [1, 9, 3, 11])) call abort()
+  end subroutine
+end

diff --git a/gcc/testsuite/gfortran.dg/internal_pack_14.f90 b/gcc/testsuite/gfortran.dg/internal_pack_14.f90
new file mode 100644 (file)
index 0000000..1a4b372
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/internal_pack_14.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+!
+! PR 55072: [4.6/4.7/4.8 Regression] Missing internal_pack leads to wrong code with derived type
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+program GiBUU_neutrino_bug
+
+  Type particle
+    integer :: ID
+  End Type
+
+  type(particle), dimension(1:2,1:2) :: OutPart
+
+  OutPart(1,:)%ID = 1
+  OutPart(2,:)%ID = 2
+
+  call s1(OutPart(1,:))
+
+contains
+
+  subroutine s1(j)
+    type(particle) :: j(:)
+    print *,j(:)%ID
+    call s2(j)
+  end subroutine
+
+  subroutine s2(k)
+    type(particle) :: k(1:2)
+    print *,k(:)%ID
+    if (any (k(1:2)%ID /= [1, 1])) call abort()
+  end subroutine
+
+end