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

re PR fortran/31867 ([4.2 only] function result with character LEN computed at run time)

Browse Source 
2007-05-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31867
	PR fortran/31994
	* trans-array.c (gfc_conv_expr_descriptor): Obtain the stored
	offset for non-descriptor, source arrays and correct for stride
	not equal to one before writing to field of output descriptor.

2007-05-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31867
	* gfortran.dg/char_length_5.f90: New test.

	PR fortran/31994
	* gfortran.dg/array_reference_1.f90: New test.

From-SVN: r124903
This commit is contained in:
Paul Thomas 2007-05-21 13:16:06 +00:00
parent 4d8a8a0a22
commit c4ba884897
5 changed files with 130 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2007-05-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31867
PR fortran/31994
* trans-array.c (gfc_conv_expr_descriptor): Obtain the stored
offset for non-descriptor, source arrays and correct for stride
not equal to one before writing to field of output descriptor.
2007-05-20 Daniel Franke <franke.daniel@gmail.com>
PR fortran/32001

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

@ -4595,6 +4595,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
if (se->direct_byref)
base = gfc_index_zero_node;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
else
base = NULL_TREE;
@ -4668,8 +4670,20 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
stride, info->stride[dim]);
if (se->direct_byref)
base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
base, stride);
{
base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
base, stride);
}
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
tmp = gfc_conv_array_lbound (desc, n);
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
tmp, loop.from[dim]);
tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
tmp, gfc_conv_array_stride (desc, n));
base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
tmp, base);
}
/* Store the new stride. */
tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
@ -4690,7 +4704,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
}
if (se->direct_byref && !se->data_not_needed)
if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
&& !se->data_not_needed)
{
/* Set the offset. */
tmp = gfc_conv_descriptor_offset (parm);

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2007-05-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31867
* gfortran.dg/char_length_5.f90: New test.
PR fortran/31994
* gfortran.dg/array_reference_1.f90: New test.
2007-05-20 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
PR middle-end/7651

35
gcc/testsuite/gfortran.dg/array_reference_1.f90 Normal file
View File

@ -0,0 +1,35 @@
! { dg-do run }
! Tests the fix for PR31994, aka 31867, in which the offset
! of 'a' in both subroutines was being evaluated incorrectly.
! The testcase for PR31867 is char_length_5.f90
!
! Contributed by Elizabeth Yip <elizabeth.l.yip@boeing.com>
! and Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
program main
call PR31994
call PR31994_comment6
contains
subroutine PR31994
implicit none
complex (kind=4), dimension(2,2) :: a, b, c
a(1,1) = (1.,1.)
a(2,1) = (2.,2.)
a(1,2) = (3.,3.)
a(2,2) = (4.,4.)
b=conjg (transpose (a))
c=transpose (a)
c=conjg (c)
if (any (b .ne. c)) call abort ()
end subroutine PR31994
subroutine PR31994_comment6
implicit none
real ,dimension(2,2)::a
integer ,dimension(2,2) :: b, c
a = reshape ((/1.,2.,3.,4./), (/2,2/))
b=int (transpose(a))
c = int (a)
c = transpose (c)
if (any (b .ne. c)) call abort ()
end subroutine PR31994_comment6
END program main

61
gcc/testsuite/gfortran.dg/char_length_5.f90 Normal file
View File

@ -0,0 +1,61 @@
! { dg-do run }
! Tests the fix for PR31867, in which the interface evaluation
! of the character length of 'join' (ie. the length available in
! the caller) was wrong.
!
! Contributed by <beliavsky@aol.com>
!
module util_mod
implicit none
contains
function join (words, sep) result(str)
character (len=*), intent(in) :: words(:),sep
character (len = (size (words) - 1) * len_trim (sep) + &
sum (len_trim (words))) :: str
integer :: i,nw
nw = size (words)
str = ""
if (nw < 1) then
return
else
str = words(1)
end if
do i=2,nw
str = trim (str) // trim (sep) // words(i)
end do
end function join
end module util_mod
!
program xjoin
use util_mod, only: join
implicit none
integer yy
character (len=5) :: words(5:8) = (/"two ","three","four ","five "/), sep = "^#^"
character (len=5) :: words2(4) = (/"bat ","ball ","goal ","stump"/), sep2 = "&"
if (join (words, sep) .ne. "two^#^three^#^four^#^five") call abort ()
if (len (join (words, sep)) .ne. 25) call abort ()
if (join (words(5:6), sep) .ne. "two^#^three") call abort ()
if (len (join (words(5:6), sep)) .ne. 11) call abort ()
if (join (words(7:8), sep) .ne. "four^#^five") call abort ()
if (len (join (words(7:8), sep)) .ne. 11) call abort ()
if (join (words(5:7:2), sep) .ne. "two^#^four") call abort ()
if (len (join (words(5:7:2), sep)) .ne. 10) call abort ()
if (join (words(6:8:2), sep) .ne. "three^#^five") call abort ()
if (len (join (words(6:8:2), sep)) .ne. 12) call abort ()
if (join (words2, sep2) .ne. "bat&ball&goal&stump") call abort ()
if (len (join (words2, sep2)) .ne. 19) call abort ()
if (join (words2(1:2), sep2) .ne. "bat&ball") call abort ()
if (len (join (words2(1:2), sep2)) .ne. 8) call abort ()
if (join (words2(2:4:2), sep2) .ne. "ball&stump") call abort ()
if (len (join (words2(2:4:2), sep2)) .ne. 10) call abort ()
end program xjoin
! { dg-final { cleanup-modules "util_mod" } }