FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: fix corner case of IBITS intrinsic [PR108937]

Browse source 
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.
This commit is contained in:
Harald Anlauf 2023-02-27 21:37:11 +01:00
parent 8020c9c423
commit 6cce953ebe
2 changed files with 42 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/fortran/trans-intrinsic.cc
View file

@ -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]);

32
gcc/testsuite/gfortran.dg/ibits_2.f90 Normal file
View file

@ -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