From bb68c20e1f3c673ed00e0e1abd468d8f19cd2072 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 27 Feb 2023 21:37:11 +0100
Subject: [PATCH 524/547] Fortran: fix corner case of IBITS intrinsic
 [PR108937]

gcc/fortran/ChangeLog:

	PR fortran/108937
	* trans-intrinsic.cc (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)
---
 gcc/fortran/trans-intrinsic.cc        | 10 +++++++++
 gcc/testsuite/gfortran.dg/ibits_2.f90 | 32 +++++++++++++++++++++++++++
 2 files changed, 42 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/ibits_2.f90

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 86e0bf9655f..c30cdfd37f9 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -6631,6 +6631,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]);
@@ -6671,8 +6672,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
-- 
2.25.1

