This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]