From 014e0d24c3051cbb990be704f980cd2958994d82 Mon Sep 17 00:00:00 2001 From: tkoenig Date: Sat, 14 Jul 2007 20:39:10 +0000 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 9 +++++ gcc/fortran/iresolve.c | 54 +++++++++++++++++++++-------- gcc/testsuite/ChangeLog | 6 ++++ gcc/testsuite/gfortran.dg/pack_mask_1.f90 | 9 +++++ gcc/testsuite/gfortran.dg/unpack_mask_1.f90 | 12 +++++++ 5 files changed, 75 insertions(+), 15 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pack_mask_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/unpack_mask_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3c72673..90a9d75 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 b0a1c37..66a3c2f 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 7d9d436..d016ec0 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 0000000..e81d4e7 --- /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 0000000..628473f --- /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 -- 2.7.4