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

re PR libfortran/32731 (pack/unpack with kind=1 or kind=2 mask)

Browse Source 
2007-07-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32731
	* iresolve.c(gfc_resolve_pack):  A scalar mask has
	to be kind=4, an array mask with kind<4 is converted
	to gfc_default_logical_kind automatically.
	(gfc_resolve_unpack):  Convert mask to gfc_default_lotical_kind
	if it has a kind<4.

2007-07-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/32731
	* gfortran.dg/pack_mask_1.f90:  New test.
	* gfortran.dg/unpack_mask_1.f90:  New test.

From-SVN: r126644
This commit is contained in:
Thomas Koenig 2007-07-14 20:39:10 +00:00
parent 27e3a7bc8d
commit 3b3620db92
5 changed files with 77 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View File

@ -1,3 +1,12 @@
2007-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32731
* iresolve.c(gfc_resolve_pack): A scalar mask has
to be kind=4, an array mask with kind<4 is converted
to gfc_default_logical_kind automatically.
(gfc_resolve_unpack): Convert mask to gfc_default_lotical_kind
if it has a kind<4.
2007-07-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/32724

58
gcc/fortran/iresolve.c
View File

@ -1556,29 +1556,42 @@ void
gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
gfc_expr *vector ATTRIBUTE_UNUSED)
{
int newkind;
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX ("pack_char") : PREFIX ("pack"));
/* The mask can be kind 4 or 8 for the array case. For the scalar
case, coerce it to kind=4 unconditionally (because this is the only
kind we have a library function for). */
newkind = 0;
if (mask->rank == 0)
{
if (mask->ts.kind != 4)
newkind = 4;
}
else
{
/* We convert mask to default logical only in the scalar case.
In the array case we can simply read the array as if it were
of type default logical. */
if (mask->ts.kind != gfc_default_logical_kind)
{
gfc_typespec ts;
ts.type = BT_LOGICAL;
ts.kind = gfc_default_logical_kind;
gfc_convert_type (mask, &ts, 2);
}
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
if (mask->ts.kind < 4)
newkind = gfc_default_logical_kind;
}
if (newkind)
{
gfc_typespec ts;
ts.type = BT_LOGICAL;
ts.kind = gfc_default_logical_kind;
gfc_convert_type (mask, &ts, 2);
}
if (mask->rank != 0)
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX ("pack_char") : PREFIX ("pack"));
else
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
}
@ -2339,6 +2352,17 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
f->ts = vector->ts;
f->rank = mask->rank;
/* Coerce the mask to default logical kind if it has kind < 4. */
if (mask->ts.kind < 4)
{
gfc_typespec ts;
ts.type = BT_LOGICAL;
ts.kind = gfc_default_logical_kind;
gfc_convert_type (mask, &ts, 2);
}
f->value.function.name
= gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
vector->ts.type == BT_CHARACTER ? "_char" : "");

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2007-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/32731
* gfortran.dg/pack_mask_1.f90: New test.
* gfortran.dg/unpack_mask_1.f90: New test.
2007-07-14 Eric Botcazou <ebotcazou@libertysurf.fr>
* gcc.dg/20001013-1.c: Move to gcc.target/sparc.

9
gcc/testsuite/gfortran.dg/pack_mask_1.f90 Normal file
View File

@ -0,0 +1,9 @@
! { dg-do run }
! PR 32721 - missing conversion for kind=1 and kind=2 masks for pack
program main
real, dimension(2,2) :: a
real, dimension(4) :: b
call random_number(a)
b = pack(a,logical(a>0,kind=1))
b = pack(a,logical(a>0,kind=2))
end program main

12
gcc/testsuite/gfortran.dg/unpack_mask_1.f90 Normal file
View File

@ -0,0 +1,12 @@
! { dg-do run }
! PR 32731 - upack lacked conversion for kind=1 and kind=2 mask
program main
implicit none
character(len=80) line
logical(kind=1),dimension(2,2) :: mask1
logical(kind=1),dimension(2,2) :: mask2
mask1 = .true.
mask2 = .true.
write(unit=line,fmt='(4I4)') unpack((/1,2,3,4/),mask1,0)
write(unit=line,fmt='(4I4)') unpack((/1,2,3,4/),mask2,0)
end program main