This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, PR 32731] fix pack and unpack for kind=1 and kind=2 mask
- From: Thomas Koenig <tkoenig at alice-dsl dot net>
- To: fortran at gcc dot gnu dot org
- Cc: gcc-patches at gcc dot gnu dot org
- Date: Fri, 13 Jul 2007 21:39:57 +0200
- Subject: [patch, PR 32731] fix pack and unpack for kind=1 and kind=2 mask
Hello world,
this patch fixes PR 32731 (wrong-code for kind=1 and kind=2 mask).
It should be mostly self-explanatory.
The reason why I hard-coded the magic number 4 in a few places is
because we only have kind=4 masks for scalar masks, and the GFC_LOGICAL
conversion trick is also hardcoded in the library. I also would have
felt silly defining a GFC_DEFAULT_DEFAULT_LOGICAL_KIND, but I'm open
to suggestions.
Currently regression-testing on i686-pc-linux-gnu. OK for trunk if this
passes?
Thomas
2007-07-13 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-13 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.
Index: iresolve.c
===================================================================
--- iresolve.c (revision 126460)
+++ iresolve.c (working copy)
@@ -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;
+ if (mask->ts.kind < 4)
+ newkind = gfc_default_logical_kind;
+ }
- ts.type = BT_LOGICAL;
- ts.kind = gfc_default_logical_kind;
- gfc_convert_type (mask, &ts, 2);
- }
+ if (newkind)
+ {
+ gfc_typespec ts;
- f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
+ 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_exp
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" : "");
! { 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
! { 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