From: tkoenig Date: Sat, 14 Jul 2007 20:39:10 +0000 (+0000) Subject: 2007-07-14 Thomas Koenig X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=014e0d24c3051cbb990be704f980cd2958994d82 2007-07-14 Thomas Koenig 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 PR libfortran/32731 * gfortran.dg/pack_mask_1.f90: New test. * gfortran.dg/unpack_mask_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126644 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3c726735688..90a9d75904b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2007-07-14 Thomas Koenig + + 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 PR fortran/32724 diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index b0a1c37dda6..66a3c2f52e5 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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_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" : ""); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7d9d43679c2..d016ec010dd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-07-14 Thomas Koenig + + PR libfortran/32731 + * gfortran.dg/pack_mask_1.f90: New test. + * gfortran.dg/unpack_mask_1.f90: New test. + 2007-07-14 Eric Botcazou * gcc.dg/20001013-1.c: Move to gcc.target/sparc. diff --git a/gcc/testsuite/gfortran.dg/pack_mask_1.f90 b/gcc/testsuite/gfortran.dg/pack_mask_1.f90 new file mode 100644 index 00000000000..e81d4e76ee2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pack_mask_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/unpack_mask_1.f90 b/gcc/testsuite/gfortran.dg/unpack_mask_1.f90 new file mode 100644 index 00000000000..628473fcf94 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unpack_mask_1.f90 @@ -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