OSDN Git Service

2007-08-01 Thomas Koenig <tkoenig@gcc.gnu.org>
authortkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 1 Aug 2007 20:27:27 +0000 (20:27 +0000)
committertkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 1 Aug 2007 20:27:27 +0000 (20:27 +0000)
PR libfortran/32954
* intrinsic.c (resolve_mask_arg):  New function.
(gfc_resolve_maxloc):  Use resolve_mask_arg for mask resolution.
(gfc_resolve_maxval):  Likewise.
(gfc_resolve_minloc):  Likewise.
(gfc_resolve_minval):  Likewise.
(gfc_resolve_pack):  Likewise.
(gfc_resolve_product):  Likewise.
(gfc_resolve_sum):  Likewise.
(gfc_resolve_unpack):  Likewise.

2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>

PR libfortran/32954
* minmaxloc_3.f90:  New test case.

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

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

index 81bff2b..1d6ca66 100644 (file)
@@ -1,3 +1,16 @@
+2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR libfortran/32954
+       * intrinsic.c (resolve_mask_arg):  New function.
+       (gfc_resolve_maxloc):  Use resolve_mask_arg for mask resolution.
+       (gfc_resolve_maxval):  Likewise.
+       (gfc_resolve_minloc):  Likewise.
+       (gfc_resolve_minval):  Likewise.
+       (gfc_resolve_pack):  Likewise.
+       (gfc_resolve_product):  Likewise.
+       (gfc_resolve_sum):  Likewise.
+       (gfc_resolve_unpack):  Likewise.
+
 2007-08-01  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/32936
index 9c388c5..32ed6da 100644 (file)
@@ -72,6 +72,41 @@ check_charlen_present (gfc_expr *source)
     }
 }
 
+/* Helper function for resolving the "mask" argument.  */
+
+static void
+resolve_mask_arg (gfc_expr *mask)
+{
+  int newkind;
+
+  /* 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
+    {
+      if (mask->ts.kind < 4)
+       newkind = gfc_default_logical_kind;
+    }
+
+  if (newkind)
+    {
+      gfc_typespec ts;
+
+      ts.type = BT_LOGICAL;
+      ts.kind = newkind;
+      gfc_convert_type (mask, &ts, 2);
+    }
+}
+
 /********************** Resolution functions **********************/
 
 
@@ -1232,16 +1267,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mmaxloc";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "maxloc";
@@ -1286,16 +1312,7 @@ gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mmaxval";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "maxval";
@@ -1386,16 +1403,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mminloc";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "minloc";
@@ -1440,16 +1448,7 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mminval";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "minval";
@@ -1555,35 +1554,10 @@ 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;
 
-  /* 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
-    {
-      if (mask->ts.kind < 4)
-       newkind = gfc_default_logical_kind;
-    }
-
-  if (newkind)
-    {
-      gfc_typespec ts;
-
-      ts.type = BT_LOGICAL;
-      ts.kind = gfc_default_logical_kind;
-      gfc_convert_type (mask, &ts, 2);
-    }
+  resolve_mask_arg (mask);
 
   if (mask->rank != 0)
     f->value.function.name = (array->ts.type == BT_CHARACTER
@@ -1615,16 +1589,7 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
       else
        name = "mproduct";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "product";
@@ -2112,16 +2077,7 @@ gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
       else
        name = "msum";
 
-      /* The mask can be kind 4 or 8 for the array case.  For the
-        scalar case, coerce it to default kind unconditionally.  */
-      if ((mask->ts.kind < gfc_default_logical_kind)
-         || (mask->rank == 0 && mask->ts.kind != gfc_default_logical_kind))
-       {
-         gfc_typespec ts;
-         ts.type = BT_LOGICAL;
-         ts.kind = gfc_default_logical_kind;
-         gfc_convert_type_warn (mask, &ts, 2, 0);
-       }
+      resolve_mask_arg (mask);
     }
   else
     name = "sum";
@@ -2350,17 +2306,7 @@ 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);
-    }
+  resolve_mask_arg (mask);
 
   f->value.function.name
     = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
index 0755f4f..15364b9 100644 (file)
@@ -1,3 +1,8 @@
+2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR libfortran/32954
+       * minmaxloc_3.f90:  New test case.
+
 2007-08-01  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/32936
diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_3.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_3.f90
new file mode 100644 (file)
index 0000000..fbc1b09
--- /dev/null
@@ -0,0 +1,119 @@
+! { dg-do run }
+! { dg-options "-fdefault-integer-8" }
+! Check max/minloc.
+! PR fortran/32956, wrong mask kind with -fdefault-integer-8
+!
+program test
+  implicit none
+  integer :: i(1), j(-1:1), res(1)
+  logical, volatile :: m(3), m2(3)
+  m = (/ .false., .false., .false. /)
+  m2 = (/ .false., .true., .false. /)
+  call check(1, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.))
+  call check(2, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m))
+  call check(3, 2, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m2))
+  call check(4, 0, MAXLOC(i(1:0), DIM=1, MASK=.TRUE.))
+  call check(5, 0, MAXLOC(i(1:0), DIM=1, MASK=.FALSE.))
+  call check(6, 0, MAXLOC(i(1:0), DIM=1, MASK=m(1:0)))
+  call check(7, 0, MAXLOC(i(1:0), DIM=1))
+  call check(8, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.))
+  call check(9, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=m))
+  call check(10, 0, MINLOC(i(1:0), DIM=1, MASK=.FALSE.))
+  call check(11,0, MINLOC(i(1:0), DIM=1, MASK=m(1:0)))
+  call check(12,0, MINLOC(i(1:0), DIM=1, MASK=.TRUE.))
+  call check(13,0, MINLOC(i(1:0), DIM=1))
+
+  j = (/ 1, 2, 1 /); call check(14, 2, MAXLOC(j, DIM=1))
+  j = (/ 1, 2, 3 /); call check(15, 3, MAXLOC(j, DIM=1))
+  j = (/ 3, 2, 1 /); call check(16, 1, MAXLOC(j, DIM=1))
+  j = (/ 1, 2, 1 /); call check(17, 1, MINLOC(j, DIM=1))
+  j = (/ 1, 2, 3 /); call check(18, 1, MINLOC(j, DIM=1))
+  j = (/ 3, 2, 1 /); call check(19, 3, MINLOC(j, DIM=1))
+
+  j = (/ 1, 2, 1 /); call check(20, 2, MAXLOC(j, DIM=1,mask=.true.))
+  j = (/ 1, 2, 3 /); call check(21, 3, MAXLOC(j, DIM=1,mask=.true.))
+  j = (/ 3, 2, 1 /); call check(22, 1, MAXLOC(j, DIM=1,mask=.true.))
+  j = (/ 1, 2, 1 /); call check(23, 1, MINLOC(j, DIM=1,mask=.true.))
+  j = (/ 1, 2, 3 /); call check(24, 1, MINLOC(j, DIM=1,mask=.true.))
+  j = (/ 3, 2, 1 /); call check(25, 3, MINLOC(j, DIM=1,mask=.true.))
+
+  j = (/ 1, 2, 1 /); call check(26, 0, MAXLOC(j, DIM=1,mask=.false.))
+  j = (/ 1, 2, 3 /); call check(27, 0, MAXLOC(j, DIM=1,mask=.false.))
+  j = (/ 3, 2, 1 /); call check(28, 0, MAXLOC(j, DIM=1,mask=.false.))
+  j = (/ 1, 2, 1 /); call check(29, 0, MINLOC(j, DIM=1,mask=.false.))
+  j = (/ 1, 2, 3 /); call check(30, 0, MINLOC(j, DIM=1,mask=.false.))
+  j = (/ 3, 2, 1 /); call check(31, 0, MINLOC(j, DIM=1,mask=.false.))
+
+  j = (/ 1, 2, 1 /); call check(32, 0, MAXLOC(j, DIM=1,mask=m))
+  j = (/ 1, 2, 3 /); call check(33, 0, MAXLOC(j, DIM=1,mask=m))
+  j = (/ 3, 2, 1 /); call check(34, 0, MAXLOC(j, DIM=1,mask=m))
+  j = (/ 1, 2, 1 /); call check(35, 0, MINLOC(j, DIM=1,mask=m))
+  j = (/ 1, 2, 3 /); call check(36, 0, MINLOC(j, DIM=1,mask=m))
+  j = (/ 3, 2, 1 /); call check(37, 0, MINLOC(j, DIM=1,mask=m))
+
+  j = (/ 1, 2, 1 /); call check(38, 2, MAXLOC(j, DIM=1,mask=m2))
+  j = (/ 1, 2, 3 /); call check(39, 2, MAXLOC(j, DIM=1,mask=m2))
+  j = (/ 3, 2, 1 /); call check(40, 2, MAXLOC(j, DIM=1,mask=m2))
+  j = (/ 1, 2, 1 /); call check(41, 2, MINLOC(j, DIM=1,mask=m2))
+  j = (/ 1, 2, 3 /); call check(42, 2, MINLOC(j, DIM=1,mask=m2))
+  j = (/ 3, 2, 1 /); call check(43, 2, MINLOC(j, DIM=1,mask=m2))
+
+! Check the library minloc and maxloc
+  res = MAXLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(44, 0,  res(1))
+  res = MAXLOC((/ 42, 23, 11 /), MASK=m); call check(45, 0,  res(1))
+  res = MAXLOC((/ 42, 23, 11 /), MASK=m2); call check(46, 2,  res(1))
+  res = MAXLOC(i(1:0), MASK=.TRUE.); call check(47, 0,  res(1))
+  res = MAXLOC(i(1:0), MASK=.FALSE.); call check(48, 0,  res(1))
+  res = MAXLOC(i(1:0), MASK=m(1:0)); call check(49, 0,  res(1))
+  res = MAXLOC(i(1:0)); call check(50, 0,  res(1))
+  res = MINLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(51, 0, res(1))
+  res = MINLOC((/ 42, 23, 11 /), MASK=m); call check(52, 0, res(1))
+  res = MINLOC(i(1:0), MASK=.FALSE.); call check(53, 0, res(1))
+  res = MINLOC(i(1:0), MASK=m(1:0)); call check(54,0, res(1))
+  res = MINLOC(i(1:0), MASK=.TRUE.); call check(55,0, res(1))
+  res = MINLOC(i(1:0)); call check(56,0, res(1))
+
+  j = (/ 1, 2, 1 /); res = MAXLOC(j); call check(57, 2,  res(1))
+  j = (/ 1, 2, 3 /); res = MAXLOC(j); call check(58, 3,  res(1))
+  j = (/ 3, 2, 1 /); res = MAXLOC(j); call check(59, 1,  res(1))
+  j = (/ 1, 2, 1 /); res = MINLOC(j); call check(60, 1, res(1))
+  j = (/ 1, 2, 3 /); res = MINLOC(j); call check(61, 1, res(1))
+  j = (/ 3, 2, 1 /); res = MINLOC(j); call check(62, 3, res(1))
+
+  j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(63, 2,  res(1))
+  j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.true.); call check(65, 3,  res(1))
+  j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(66, 1,  res(1))
+  j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.true.); call check(67, 1, res(1))
+  j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.true.); call check(68, 1, res(1))
+  j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.true.); call check(69, 3, res(1))
+
+  j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(70, 0,  res(1))
+  j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.false.); call check(71, 0,  res(1))
+  j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(72, 0,  res(1))
+  j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.false.); call check(73, 0, res(1))
+  j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.false.); call check(74, 0, res(1))
+  j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.false.); call check(75, 0, res(1))
+
+  j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m); call check(76, 0,  res(1))
+  j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m); call check(77, 0,  res(1))
+  j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m); call check(78, 0,  res(1))
+  j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m); call check(79, 0, res(1))
+  j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m); call check(80, 0, res(1))
+  j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m);call check(81, 0, res(1))
+
+  j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m2); call check(82, 2,  res(1))
+  j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m2); call check(83, 2,  res(1))
+  j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m2); call check(84, 2,  res(1))
+  j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m2); call check(85, 2, res(1))
+  j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m2); call check(86, 2, res(1))
+  j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m2); call check(87, 2, res(1))
+
+contains
+subroutine check(n, i,j)
+  integer, value, intent(in) :: i,j,n
+  if(i /= j) then
+     call abort()
+!    print *, 'ERROR: Test',n,' expected ',i,' received ', j
+  end if
+end subroutine check
+end program