From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 27 Feb 2023 20:37:11 +0000 (+0100)
Subject: Fortran: fix corner case of IBITS intrinsic [PR108937]
X-Git-Tag: releases/gcc-10.5.0~251
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=570828e84f751730743093e5f060eeaf98c08cac;p=thirdparty%2Fgcc.git

Fortran: fix corner case of IBITS intrinsic [PR108937]

gcc/fortran/ChangeLog:

	PR fortran/108937
	* trans-intrinsic.c (gfc_conv_intrinsic_ibits): Handle corner case
	LEN argument of IBITS equal to BITSIZE(I).

gcc/testsuite/ChangeLog:

	PR fortran/108937
	* gfortran.dg/ibits_2.f90: New test.

(cherry picked from commit 6cce953ebec274f1468d5d3a0697cf05bb43b8f6)
---

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9a4aa08f889d..1d3ad31eb59f 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6502,6 +6502,7 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
   tree type;
   tree tmp;
   tree mask;
+  tree num_bits, cond;
 
   gfc_conv_intrinsic_function_args (se, expr, args, 3);
   type = TREE_TYPE (args[0]);
@@ -6542,8 +6543,17 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
 			       "in intrinsic IBITS", tmp1, tmp2, nbits);
     }
 
+  /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
+     gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+     special case.  See also gfc_conv_intrinsic_ishft ().  */
+  num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
+
   mask = build_int_cst (type, -1);
   mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
+  cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
+			  num_bits);
+  mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			  build_int_cst (type, 0), mask);
   mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
 
   tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
diff --git a/gcc/testsuite/gfortran.dg/ibits_2.f90 b/gcc/testsuite/gfortran.dg/ibits_2.f90
new file mode 100644
index 000000000000..2af5542d764f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ibits_2.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=bits" }
+! PR fortran/108937 - Intrinsic IBITS(I,POS,LEN) fails when LEN equals
+!                     to BIT_SIZE(I)
+! Contributed by saitofuyuki@jamstec.go.jp
+
+program test_bits
+  implicit none
+  integer, parameter :: KT = kind (1)
+  integer, parameter :: lbits = bit_size (0_KT)
+  integer(kind=KT) :: x, y0, y1
+  integer(kind=KT) :: p, l
+
+  x = -1
+  p = 0
+  do l = 0, lbits
+     y0 = ibits  (x, p, l)
+     y1 = ibits_1(x, p, l)
+     if (y0 /= y1) then
+        print *, l, y0, y1
+        stop 1+l
+     end if
+  end do
+contains
+  elemental integer(kind=KT) function ibits_1(I, POS, LEN) result(n)
+    !! IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN)
+    implicit none
+    integer(kind=KT),intent(in) :: I
+    integer,         intent(in) :: POS, LEN
+    n = IAND (ISHFT(I, - POS), NOT(ISHFT(-1_KT, LEN)))
+  end function ibits_1
+end program test_bits