https://gcc.gnu.org/g:ef35d21d9218259706b1ab37766ead2ad0f3e231
commit ef35d21d9218259706b1ab37766ead2ad0f3e231
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Mon Aug 5 23:02:21 2024 +0200
Implement dshift[lr], ibclr, ibset and ibits.
Diff:
---
gcc/fortran/check.cc | 88 +++++++++++++++++++++++---------
gcc/fortran/gfortran.h | 2 +-
gcc/fortran/iresolve.cc | 30 +++++++----
gcc/fortran/simplify.cc | 72 ++++++++++++++++++--------
gcc/testsuite/gfortran.dg/unsigned_9.f90 | 32 ++++++++++++
5 files changed, 170 insertions(+), 54 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 1a8f601ce838..54a84ae40756 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -913,14 +913,20 @@ static bool
less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
{
int i, val;
+ int bit_size;
if (expr->expr_type != EXPR_CONSTANT)
return true;
- i = gfc_validate_kind (BT_INTEGER, k, false);
+ i = gfc_validate_kind (expr->ts.type, k, false);
gfc_extract_int (expr, &val);
- if (val > gfc_integer_kinds[i].bit_size)
+ if (expr->ts.type == BT_INTEGER)
+ bit_size = gfc_integer_kinds[i].bit_size;
+ else
+ bit_size = gfc_unsigned_kinds[i].bit_size;
+
+ if (val > bit_size)
{
gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
"INTEGER(KIND=%d)", arg, &expr->where, k);
@@ -939,14 +945,21 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1,
const char *arg2,
gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
{
int i2, i3;
+ int k, bit_size;
if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
{
gfc_extract_int (expr2, &i2);
gfc_extract_int (expr3, &i3);
i2 += i3;
- i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
- if (i2 > gfc_integer_kinds[i3].bit_size)
+ k = gfc_validate_kind (expr1->ts.type, expr1->ts.kind, false);
+
+ if (expr1->ts.type == BT_INTEGER)
+ bit_size = gfc_integer_kinds[k].bit_size;
+ else
+ bit_size = gfc_unsigned_kinds[k].bit_size;
+
+ if (i2 > bit_size)
{
gfc_error ("%<%s + %s%> at %L must be less than or equal "
"to BIT_SIZE(%qs)",
@@ -2822,33 +2835,54 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr
*shift)
if (!boz_args_check (i, j))
return false;
- /* If i is BOZ and j is integer, convert i to type of j. If j is not
- an integer, clear the BOZ; otherwise, check that i is an integer. */
if (i->ts.type == BT_BOZ)
{
- if (j->ts.type != BT_INTEGER)
- reset_boz (i);
- else if (!gfc_boz2int (i, j->ts.kind))
- return false;
+ if (j->ts.type == BT_INTEGER)
+ {
+ if (!gfc_boz2int (i, j->ts.kind))
+ return false;
+ }
+ else if (flag_unsigned && j->ts.type == BT_UNSIGNED)
+ {
+ if (!gfc_boz2uint (i, j->ts.kind))
+ return false;
+ }
+ else
+ reset_boz (i);
}
- else if (!type_check (i, 0, BT_INTEGER))
+
+ if (j->ts.type == BT_BOZ)
{
- if (j->ts.type == BT_BOZ)
+ if (i->ts.type == BT_INTEGER)
+ {
+ if (!gfc_boz2int (j, i->ts.kind))
+ return false;
+ }
+ else if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+ {
+ if (!gfc_boz2uint (j, i->ts.kind))
+ return false;
+ }
+ else
reset_boz (j);
- return false;
}
- /* If j is BOZ and i is integer, convert j to type of i. If i is not
- an integer, clear the BOZ; otherwise, check that i is an integer. */
- if (j->ts.type == BT_BOZ)
+ if (flag_unsigned)
{
- if (i->ts.type != BT_INTEGER)
- reset_boz (j);
- else if (!gfc_boz2int (j, i->ts.kind))
+ if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+ return false;
+
+ if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED))
+ return false;
+ }
+ else
+ {
+ if (!type_check (i, 0, BT_INTEGER))
+ return false;
+
+ if (!type_check (j, 1, BT_INTEGER))
return false;
}
- else if (!type_check (j, 1, BT_INTEGER))
- return false;
if (!same_type_check (i, 0, j, 1))
return false;
@@ -3231,8 +3265,16 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
bool
gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
{
- if (!type_check (i, 0, BT_INTEGER))
- return false;
+ if (flag_unsigned)
+ {
+ if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+ return false;
+ }
+ else
+ {
+ if (!type_check (i, 0, BT_INTEGER))
+ return false;
+ }
if (!type_check (pos, 1, BT_INTEGER))
return false;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5f8dd1300a50..16395a35b030 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3474,7 +3474,7 @@ arith gfc_check_integer_range (mpz_t p, int kind);
arith gfc_check_unsigned_range (mpz_t p, int kind);
bool gfc_check_character_range (gfc_char_t, int);
const char *gfc_arith_error (arith);
-void gfc_reduce_unigned (gfc_expr *e);
+void gfc_reduce_unsigned (gfc_expr *e);
extern bool gfc_seen_div0;
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 845c99f18ddf..8e2ad8780f8c 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -895,11 +895,13 @@ void
gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
gfc_expr *shift ATTRIBUTE_UNUSED)
{
+ char c = i->ts.type == BT_INTEGER ? 'i' : 'u';
+
f->ts = i->ts;
if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
- f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
+ f->value.function.name = gfc_get_string ("dshiftl_%c%d", c, f->ts.kind);
else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
- f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
+ f->value.function.name = gfc_get_string ("dshiftr_%c%d", c, f->ts.kind);
else
gcc_unreachable ();
}
@@ -1182,6 +1184,7 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
+
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i, j))
@@ -1191,7 +1194,8 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
}
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__iand_u_%d" : "__iand_%d";
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
@@ -1206,7 +1210,8 @@ void
gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__ibclr_u_%d" : "__ibclr_%d";
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
@@ -1215,7 +1220,8 @@ gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr
*pos ATTRIBUTE_UNUSED,
gfc_expr *len ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__ibits_u_%d" : "__ibits_%d";
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
@@ -1223,7 +1229,8 @@ void
gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__ibset_u_%d" : "__ibset_%d";
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
@@ -1273,6 +1280,7 @@ gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
+
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i, j))
@@ -1281,8 +1289,9 @@ gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
gfc_convert_type (i, &j->ts, 2);
}
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__ieor_u_%d" : "__ieor_%d";
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
@@ -1292,6 +1301,7 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
+
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i, j))
@@ -1300,8 +1310,9 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
gfc_convert_type (i, &j->ts, 2);
}
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__ior_u_%d" : "__ior_%d";
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
@@ -2225,7 +2236,8 @@ void
gfc_resolve_not (gfc_expr *f, gfc_expr *i)
{
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
+ const char *name = i->ts.kind == BT_UNSIGNED ? "__not_u_%d" : "__not_%d";
+ f->value.function.name = gfc_get_string (name, i->ts.kind);
}
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 1818dc5956cc..b7b280754e90 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -2493,13 +2493,23 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2,
gfc_expr *shiftarg,
{
gfc_expr *result;
int i, k, size, shift;
+ bt type = BT_INTEGER;
if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
|| shiftarg->expr_type != EXPR_CONSTANT)
return NULL;
- k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
- size = gfc_integer_kinds[k].bit_size;
+ if (flag_unsigned && arg1->ts.type == BT_UNSIGNED)
+ {
+ k = gfc_validate_kind (BT_UNSIGNED, arg1->ts.kind, false);
+ size = gfc_unsigned_kinds[k].bit_size;
+ type = BT_UNSIGNED;
+ }
+ else
+ {
+ k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
+ size = gfc_integer_kinds[k].bit_size;
+ }
gfc_extract_int (shiftarg, &shift);
@@ -2507,7 +2517,7 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr
*shiftarg,
if (right)
shift = size - shift;
- result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
+ result = gfc_get_constant_expr (type, arg1->ts.kind, &arg1->where);
mpz_set_ui (result->value.integer, 0);
for (i = 0; i < shift; i++)
@@ -2518,8 +2528,11 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2,
gfc_expr *shiftarg,
if (mpz_tstbit (arg1->value.integer, i))
mpz_setbit (result->value.integer, shift + i);
- /* Convert to a signed value. */
- gfc_convert_mpz_to_signed (result->value.integer, size);
+ /* Convert to a signed value if needed. */
+ if (type == BT_INTEGER)
+ gfc_convert_mpz_to_signed (result->value.integer, size);
+ else
+ gfc_reduce_unsigned (result);
return result;
}
@@ -3448,13 +3461,18 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
result->representation.string = NULL;
}
- gfc_convert_mpz_to_unsigned (result->value.integer,
- gfc_integer_kinds[k].bit_size);
+ if (x->ts.type == BT_INTEGER)
+ {
+ gfc_convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
- mpz_clrbit (result->value.integer, pos);
+ mpz_clrbit (result->value.integer, pos);
- gfc_convert_mpz_to_signed (result->value.integer,
- gfc_integer_kinds[k].bit_size);
+ gfc_convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+ }
+ else
+ mpz_clrbit (result->value.integer, pos);
return result;
}
@@ -3479,9 +3497,13 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr
*z)
gfc_extract_int (y, &pos);
gfc_extract_int (z, &len);
- k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
+ k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- bitsize = gfc_integer_kinds[k].bit_size;
+ if (x->ts.type == BT_INTEGER)
+ bitsize = gfc_integer_kinds[k].bit_size;
+ else
+ bitsize = gfc_unsigned_kinds[k].bit_size;
+
if (pos + len > bitsize)
{
@@ -3491,8 +3513,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr
*z)
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- gfc_convert_mpz_to_unsigned (result->value.integer,
- gfc_integer_kinds[k].bit_size);
+
+ if (x->ts.type == BT_INTEGER)
+ gfc_convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
bits = XCNEWVEC (int, bitsize);
@@ -3514,8 +3538,9 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
free (bits);
- gfc_convert_mpz_to_signed (result->value.integer,
- gfc_integer_kinds[k].bit_size);
+ if (x->ts.type == BT_INTEGER)
+ gfc_convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
return result;
}
@@ -3546,13 +3571,18 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
result->representation.string = NULL;
}
- gfc_convert_mpz_to_unsigned (result->value.integer,
- gfc_integer_kinds[k].bit_size);
+ if (x->ts.type == BT_INTEGER)
+ {
+ gfc_convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
- mpz_setbit (result->value.integer, pos);
+ mpz_setbit (result->value.integer, pos);
- gfc_convert_mpz_to_signed (result->value.integer,
- gfc_integer_kinds[k].bit_size);
+ gfc_convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+ }
+ else
+ mpz_setbit (result->value.integer, pos);
return result;
}
diff --git a/gcc/testsuite/gfortran.dg/unsigned_9.f90
b/gcc/testsuite/gfortran.dg/unsigned_9.f90
new file mode 100644
index 000000000000..2627ccf537b8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_9.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test dshiftl, dshiftr, ibclr, ibset and ibits intrinsics.
+program main
+ unsigned :: u, v, w
+ integer :: i, j, k
+
+ u = 1u; v = 4u
+ i = 1; j = 4
+ if (int(dshiftl(u,v,12)) /= dshiftl(i,j,12)) error stop 1
+ if (int(dshiftl(1u,4u,12)) /= dshiftl(1,4,12)) error stop 2
+ if (int(dshiftr(u,v,12)) /= dshiftr(i,j,12)) error stop 3
+ if (int(dshiftr(1u,4u,12)) /= dshiftr(1,4,12)) error stop 4
+
+ k = 14
+
+ if (int(dshiftl(u,v,k)) /= dshiftl(i,j,k)) error stop 5
+ if (int(dshiftl(1u,4u,k)) /= dshiftl(1,4,k)) error stop 6
+ if (int(dshiftr(u,v,k)) /= dshiftr(i,j,k)) error stop 7
+ if (int(dshiftr(1u,4u,k)) /= dshiftr(1,4,k)) error stop 8
+
+ u = 255u
+ i = 255
+ do k=0,8
+ if (ibclr(i,k) /= int(ibclr(u,k))) error stop 9
+ if (ibset(i,k+4) /= int(ibset(u,k+4))) error stop 10
+ end do
+ if (ibclr(255,5) /= int(ibclr(255u,5))) stop 11
+ if (ibset(255,10) /= int(ibset(255u,10))) stop 12
+
+ if (uint(ibits(6,6,2)) /= ibits(6u,6,2)) stop 13
+end program main
