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.

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 21eeb12ca89d2934774c2fe9e24297d1675e1f7e..3cce9c0166efcb8df2f2c83e0621684a3b5663c0 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -6638,6 +6638,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]);
@@ -6678,8 +6679,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 (file)
index 0000000..2af5542
--- /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