]> git.ipfire.org Git - thirdparty/gcc.git/commitdiff
PR fortran/96890 - Wrong answer with intrinsic IALL
authorHarald Anlauf <anlauf@gmx.de>
Thu, 3 Sep 2020 18:33:14 +0000 (20:33 +0200)
committerHarald Anlauf <anlauf@gmx.de>
Wed, 9 Sep 2020 19:38:04 +0000 (21:38 +0200)
The IALL intrinsic would always return 0 when the DIM and MASK arguments
were present since the initial value of repeated BIT-AND operations was
set to 0 instead of -1.

libgfortran/ChangeLog:

* m4/iall.m4: Initial value for result should be -1.
* generated/iall_i1.c (miall_i1): Generated.
* generated/iall_i16.c (miall_i16): Likewise.
* generated/iall_i2.c (miall_i2): Likewise.
* generated/iall_i4.c (miall_i4): Likewise.
* generated/iall_i8.c (miall_i8): Likewise.

gcc/testsuite/ChangeLog:

* gfortran.dg/iall_masked.f90: New test.

(cherry picked from commit 8eeeecbcc17041fdfd3ccc928161ae86e7f9b456)

gcc/testsuite/gfortran.dg/iall_masked.f90 [new file with mode: 0644]
libgfortran/generated/iall_i1.c
libgfortran/generated/iall_i16.c
libgfortran/generated/iall_i2.c
libgfortran/generated/iall_i4.c
libgfortran/generated/iall_i8.c
libgfortran/m4/iall.m4

diff --git a/gcc/testsuite/gfortran.dg/iall_masked.f90 b/gcc/testsuite/gfortran.dg/iall_masked.f90
new file mode 100644 (file)
index 0000000..33cc410
--- /dev/null
@@ -0,0 +1,22 @@
+! { dg-do run }
+! PR fortran/96890 - Wrong answer with intrinsic IALL
+program p
+  implicit none
+  integer :: iarr1(0), iarr2(2,2), iarr3(2,2,2)
+  logical :: mask1(0), mask2(2,2), mask3(2,2,2)
+
+  if (     iall(iarr1,    mask1) /=          -1                 ) stop 1
+  if (     iall(iarr1, 1, mask1) /=          -1                 ) stop 2
+
+  iarr2 = reshape ([  1,      2,       3,      4      ], shape (iarr2))
+  mask2 = reshape ([ .true., .false., .true., .false. ], shape (mask2))
+
+  if (any (iall(iarr2, 2, mask2) /=          [1,-1])            ) stop 3
+
+  iarr3 = reshape ([  1,      2,       3,      4,     &
+                      5,      6,       7,      8      ], shape (iarr3))
+  mask3 = reshape ([ .true., .false., .true., .false.,&
+                     .true., .false., .true., .false. ], shape (iarr3))
+
+  if (any (iall(iarr3, 2, mask3) /= reshape ([1,-1,5,-1],[2,2]))) stop 4
+end
index 3e848ff678777d866324f0c8bdef04ef3935dab2..23f558228123ec322c31ee51f04d9cc406b494ce 100644 (file)
@@ -345,7 +345,7 @@ miall_i1 (gfc_array_i1 * const restrict retarray,
       msrc = mbase;
       {
 
-  result = 0;
+  result = (GFC_INTEGER_1) -1;
        for (n = 0; n < len; n++, src += delta, msrc += mdelta)
          {
 
index 29a056eecab5662210be81b7171e74566e220dcf..c90c5e6c40e42430cabe9a8c763610545c36da30 100644 (file)
@@ -345,7 +345,7 @@ miall_i16 (gfc_array_i16 * const restrict retarray,
       msrc = mbase;
       {
 
-  result = 0;
+  result = (GFC_INTEGER_16) -1;
        for (n = 0; n < len; n++, src += delta, msrc += mdelta)
          {
 
index 6a6c9936d7182d9d9ec844e11039e7aa32cca0a6..a2fd671e3be13408fa9748eafbb9976f76c87517 100644 (file)
@@ -345,7 +345,7 @@ miall_i2 (gfc_array_i2 * const restrict retarray,
       msrc = mbase;
       {
 
-  result = 0;
+  result = (GFC_INTEGER_2) -1;
        for (n = 0; n < len; n++, src += delta, msrc += mdelta)
          {
 
index cdba6c8c7622abd7408eca98fbb06977e966175f..03f9ef9cbf20ffda92fc6ab4c9c82f9b2468d787 100644 (file)
@@ -345,7 +345,7 @@ miall_i4 (gfc_array_i4 * const restrict retarray,
       msrc = mbase;
       {
 
-  result = 0;
+  result = (GFC_INTEGER_4) -1;
        for (n = 0; n < len; n++, src += delta, msrc += mdelta)
          {
 
index 5cd7353013da08e9fe02684e47e0f736d980c414..3b9cc9197b6f1376f20ccfee34437350903f262e 100644 (file)
@@ -345,7 +345,7 @@ miall_i8 (gfc_array_i8 * const restrict retarray,
       msrc = mbase;
       {
 
-  result = 0;
+  result = (GFC_INTEGER_8) -1;
        for (n = 0; n < len; n++, src += delta, msrc += mdelta)
          {
 
index 41c8c2685868b4904d16edf845f9fcb2fef8c6b1..7de1ceb49257e81ad33eb2eb38b36640748e1e36 100644 (file)
@@ -35,7 +35,7 @@ ARRAY_FUNCTION(0,
 `  result &= *src;')
 
 MASKED_ARRAY_FUNCTION(0,
-`  result = 0;',
+`  result = ('rtype_name`) -1;',
 `  if (*msrc)
     result &= *src;')