From e86c60926a7ece32b22d4c9df18c9d7ec6276c9a Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 14 Jan 2013 22:24:36 +0100 Subject: [PATCH] re PR fortran/55072 (Missing internal_pack leads to wrong code with derived type) 2013-01-14 Janus Weil 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 PR fortran/55072 * gfortran.dg/internal_pack_13.f90: New test. * gfortran.dg/internal_pack_14.f90: New test. From-SVN: r195178 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/trans-array.c | 10 ++---- gcc/testsuite/ChangeLog | 6 ++++ .../gfortran.dg/internal_pack_13.f90 | 34 +++++++++++++++++++ .../gfortran.dg/internal_pack_14.f90 | 34 +++++++++++++++++++ 5 files changed, 82 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/internal_pack_13.f90 create mode 100644 gcc/testsuite/gfortran.dg/internal_pack_14.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 914e6d9ff123..43776e7508cd 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2013-01-14 Janus Weil + + 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 PR fortran/55618 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ce8985c23406..c3e993415ce9 100644 --- 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 dc7243714516..81664c64afdd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2013-01-14 Janus Weil + + PR fortran/55072 + * gfortran.dg/internal_pack_13.f90: New test. + * gfortran.dg/internal_pack_14.f90: New test. + 2013-01-14 Paul Thomas 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 index 000000000000..21fdc5418789 --- /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 + +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 index 000000000000..1a4b3725fbb7 --- /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 + +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 -- 2.47.2