OSDN Git Service

2007-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
authortkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 14 Jul 2007 20:39:10 +0000 (20:39 +0000)
committertkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 14 Jul 2007 20:39:10 +0000 (20:39 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126644 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/iresolve.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/pack_mask_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/unpack_mask_1.f90 [new file with mode: 0644]

index 3c72673..90a9d75 100644 (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
 2007-07-14  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/32724
index b0a1c37..66a3c2f 100644 (file)
@@ -1556,29 +1556,42 @@ void
 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
                  gfc_expr *vector ATTRIBUTE_UNUSED)
 {
 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;
 
   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
     {
   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;
 
   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" : "");
   f->value.function.name
     = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
                      vector->ts.type == BT_CHARACTER ? "_char" : "");
index 7d9d436..d016ec0 100644 (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.
 2007-07-14  Eric Botcazou  <ebotcazou@libertysurf.fr>
 
        * 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 (file)
index 0000000..e81d4e7
--- /dev/null
@@ -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 (file)
index 0000000..628473f
--- /dev/null
@@ -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