mirror/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2024-11-21 13:40:47 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Implement IANY, IALL and IPARITY for unsigned.

Browse Source 
gcc/fortran/ChangeLog:

	* check.cc (gfc_check_transf_bit_intrins): Handle unsigned.
	* gfortran.texi: Docment IANY, IALL and IPARITY for unsigned.
	* iresolve.cc (gfc_resolve_iall): Set flag to use integer
	if type is BT_UNSIGNED.
	(gfc_resolve_iany): Likewise.
	(gfc_resolve_iparity): Likewise.
	* simplify.cc (do_bit_and): Adjust asserts for BT_UNSIGNED.
	(do_bit_ior): Likewise.
	(do_bit_xor): Likewise

gcc/testsuite/ChangeLog:

	* gfortran.dg/unsigned_29.f90: New test.
This commit is contained in:
Thomas Koenig 2024-09-24 22:53:59 +02:00
parent 1762b7f89e
commit fbeb1a965d
5 changed files with 99 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/check.cc
View File

@ -4430,7 +4430,19 @@ gfc_check_mask (gfc_expr *i, gfc_expr *kind)
bool
gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
{
if (ap->expr->ts.type != BT_INTEGER)
bt type = ap->expr->ts.type;
if (flag_unsigned)
{
if (type != BT_INTEGER && type != BT_UNSIGNED)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or UNSIGNED", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &ap->expr->where);
return false;
}
}
else if (ap->expr->ts.type != BT_INTEGER)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
gfc_current_intrinsic_arg[0]->name,

1
gcc/fortran/gfortran.texi
View File

@ -2789,6 +2789,7 @@ As of now, the following intrinsics take unsigned arguments:
@item @code{RANGE}
@item @code{TRANSFER}
@item @code{SUM}, @code{PRODUCT}, @code{MATMUL} and @code{DOT_PRODUCT}
@item @code{IANY}, @code{IALL} and @code{IPARITY}
@end itemize
This list will grow in the near future.
@c ---------------------------------------------------------------------

6
gcc/fortran/iresolve.cc
View File

@ -1195,7 +1195,7 @@ gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
void
gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
resolve_transformational ("iall", f, array, dim, mask);
resolve_transformational ("iall", f, array, dim, mask, true);
}
@ -1223,7 +1223,7 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
void
gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
resolve_transformational ("iany", f, array, dim, mask);
resolve_transformational ("iany", f, array, dim, mask, true);
}
@ -1429,7 +1429,7 @@ gfc_resolve_long (gfc_expr *f, gfc_expr *a)
void
gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
resolve_transformational ("iparity", f, array, dim, mask);
resolve_transformational ("iparity", f, array, dim, mask, true);
}

51
gcc/fortran/simplify.cc
View File

@ -3401,9 +3401,20 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
static gfc_expr *
do_bit_and (gfc_expr *result, gfc_expr *e)
{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
gcc_assert (result->ts.type == BT_INTEGER
&& result->expr_type == EXPR_CONSTANT);
if (flag_unsigned)
{
gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
&& e->expr_type == EXPR_CONSTANT);
gcc_assert ((result->ts.type == BT_INTEGER
|| result->ts.type == BT_UNSIGNED)
&& result->expr_type == EXPR_CONSTANT);
}
else
{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
gcc_assert (result->ts.type == BT_INTEGER
&& result->expr_type == EXPR_CONSTANT);
}
mpz_and (result->value.integer, result->value.integer, e->value.integer);
return result;
@ -3420,9 +3431,20 @@ gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
static gfc_expr *
do_bit_ior (gfc_expr *result, gfc_expr *e)
{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
gcc_assert (result->ts.type == BT_INTEGER
&& result->expr_type == EXPR_CONSTANT);
if (flag_unsigned)
{
gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
&& e->expr_type == EXPR_CONSTANT);
gcc_assert ((result->ts.type == BT_INTEGER
|| result->ts.type == BT_UNSIGNED)
&& result->expr_type == EXPR_CONSTANT);
}
else
{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
gcc_assert (result->ts.type == BT_INTEGER
&& result->expr_type == EXPR_CONSTANT);
}
mpz_ior (result->value.integer, result->value.integer, e->value.integer);
return result;
@ -3884,9 +3906,20 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
static gfc_expr *
do_bit_xor (gfc_expr *result, gfc_expr *e)
{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
gcc_assert (result->ts.type == BT_INTEGER
&& result->expr_type == EXPR_CONSTANT);
if (flag_unsigned)
{
gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
&& e->expr_type == EXPR_CONSTANT);
gcc_assert ((result->ts.type == BT_INTEGER
|| result->ts.type == BT_UNSIGNED)
&& result->expr_type == EXPR_CONSTANT);
}
else
{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
gcc_assert (result->ts.type == BT_INTEGER
&& result->expr_type == EXPR_CONSTANT);
}
mpz_xor (result->value.integer, result->value.integer, e->value.integer);
return result;

40
gcc/testsuite/gfortran.dg/unsigned_29.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
! { dg-options "-funsigned" }
program memain
implicit none
call test1
call test2
contains
subroutine test1
unsigned, dimension(2,2) :: v
integer(8), dimension(2,2) :: i
v = reshape([4278255360u, 4042322160u, 3435973836u, 2863311530u],[2,2])
i = int(v,8)
if (iall(v) /= 2147516416u) error stop 1
if (iany(v) /= 4294901758u) error stop 2
if (iparity(v) /= 1771465110u) error stop 3
if (any(iall(v,dim=1) /= [4026593280u, 2290649224u])) error stop 4
if (any(iall(v,dim=2) /= [3422604288u, 2694881440u])) error stop 5
if (any(iany(v,dim=1) /= [4293984240u, 4008636142u])) error stop 6
if (any(iany(v,dim=2) /= [4291624908u, 4210752250u])) error stop 7
if (any(iparity(v,dim=1) /= [267390960u, 1717986918u])) error stop 8
if (any(iparity(v,dim=2) /= [869020620u, 1515870810u])) error stop 9
end subroutine test1
subroutine test2
unsigned, dimension(2,2), parameter :: v &
= reshape([4278255360u, 4042322160u, 3435973836u, 2863311530u],[2,2])
unsigned, parameter :: v_all = iall(v), v_any = iany(v), v_parity = iparity(v)
unsigned, parameter, dimension(2) :: v_all_1 = iall(v,dim=1), v_all_2 = iall(v,dim=2)
unsigned, parameter, dimension(2) :: v_any_1 = iany(v,dim=1), v_any_2 = iany(v,dim=2)
unsigned, parameter, dimension(2) :: v_parity_1 = iparity(v,dim=1), v_parity_2 = iparity(v,dim=2)
if (v_all /= 2147516416u) error stop 10
if (v_any /= 4294901758u) error stop 11
if (v_parity /= 1771465110u) error stop 12
if (any(v_all_1 /= [4026593280u, 2290649224u])) error stop 13
if (any(v_all_2 /= [3422604288u, 2694881440u])) error stop 14
if (any(v_any_1 /= [4293984240u, 4008636142u])) error stop 15
if (any(v_any_2 /= [4291624908u, 4210752250u])) error stop 16
if (any(v_parity_1 /= [267390960u, 1717986918u])) error stop 17
if (any(v_parity_2 /= [869020620u, 1515870810u])) error stop 18
end subroutine test2
end program memain