OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

2013-01-13  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-13  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: r195135
This commit is contained in:
Janus Weil 2013-01-13 13:06:04 +01:00
parent 97935f9854
commit 83d323a31d
5 changed files with 82 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2013-01-13 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-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/55618

10
gcc/fortran/trans-array.c
View File

@ -6847,20 +6847,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

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2013-01-13 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-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/55618

34
gcc/testsuite/gfortran.dg/internal_pack_13.f90 Normal file
View File

@ -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

34
gcc/testsuite/gfortran.dg/internal_pack_14.f90 Normal file
View File

@ -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