[gcc r11-10560] Fortran: fix corner case of IBITS intrinsic [PR108937]

[Harald Anlauf <anlauf@gcc.gnu.org>]

https://gcc.gnu.org/g:adc4c8eb79a75bd0f38a461c299b37c643a1153c

commit r11-10560-gadc4c8eb79a75bd0f38a461c299b37c643a1153c
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Mon Feb 27 21:37:11 2023 +0100

    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:
---
 gcc/fortran/trans-intrinsic.c         | 10 ++++++++++
 gcc/testsuite/gfortran.dg/ibits_2.f90 | 32 ++++++++++++++++++++++++++++++++
 2 files changed, 42 insertions(+)

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 313440d7022..05dc2c7c9a6 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6645,6 +6645,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]);
@@ -6685,8 +6686,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 00000000000..2af5542d764
--- /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