https://gcc.gnu.org/g:22300a5b248c1888fd70477286c8602d5a632b20
commit 22300a5b248c1888fd70477286c8602d5a632b20
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Sun Aug 4 17:50:56 2024 +0200
Bit functions, HUGE and DIGITS.
Diff:
---
gcc/fortran/arith.cc | 42 +++++++++------
gcc/fortran/check.cc | 90 ++++++++++++++++++++++++++++++--
gcc/fortran/gfortran.h | 1 +
gcc/fortran/intrinsic.cc | 2 +-
gcc/fortran/intrinsic.h | 1 +
gcc/fortran/resolve.cc | 9 ++++
gcc/fortran/simplify.cc | 22 ++++++--
gcc/testsuite/gfortran.dg/unsigned_7.f90 | 26 +++++++++
8 files changed, 167 insertions(+), 26 deletions(-)
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index b270ae8741ff..93641d91926f 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -58,7 +58,16 @@ gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
mpz_tdiv_q_2exp (z, z, -e);
}
+/* Reduce an unsigned number to within its range. */
+void
+gfc_reduce_unsigned (gfc_expr *e)
+{
+ int k;
+ gcc_checking_assert (e->expr_type == EXPR_CONSTANT && e->ts.type ==
BT_UNSIGNED);
+ k = gfc_validate_kind (BT_UNSIGNED, e->ts.kind, false);
+ mpz_and (e->value.integer, e->value.integer, gfc_unsigned_kinds[k].huge);
+}
/* Set the model number precision by the requested KIND. */
void
@@ -688,7 +697,6 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
{
gfc_expr *result;
arith rc;
- int k;
result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
@@ -702,13 +710,11 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
{
arith neg_rc;
mpz_neg (result->value.integer, op1->value.integer);
- k = gfc_validate_kind (BT_UNSIGNED, op1->ts.kind, false);
neg_rc = gfc_range_check (result);
if (neg_rc != ARITH_OK)
gfc_warning (0, gfc_arith_error (neg_rc), &result->where);
- mpz_and (result->value.integer, result->value.integer,
- gfc_unsigned_kinds[k].huge);
+ gfc_reduce_unsigned (result);
if (pedantic)
rc = neg_rc;
}
@@ -749,6 +755,11 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr
**resultp)
mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
break;
+ case BT_UNSIGNED:
+ mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
+ gfc_reduce_unsigned (result);
+ break;
+
case BT_REAL:
mpfr_add (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
@@ -783,6 +794,7 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr
**resultp)
switch (op1->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
break;
@@ -823,6 +835,11 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr
**resultp)
mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
break;
+ case BT_UNSIGNED:
+ mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
+ gfc_reduce_unsigned (result);
+ break;
+
case BT_REAL:
mpfr_mul (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
@@ -860,6 +877,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr
**resultp)
switch (op1->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
if (mpz_sgn (op2->value.integer) == 0)
{
rc = ARITH_DIV0;
@@ -2384,7 +2402,6 @@ gfc_uint2uint (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
- int k;
if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
return NULL;
@@ -2396,10 +2413,7 @@ gfc_uint2uint (gfc_expr *src, int kind)
if (rc != ARITH_OK)
gfc_warning (0, gfc_arith_error (rc), &result->where);
- k = gfc_validate_kind (BT_UNSIGNED, kind, false);
- mpz_and (result->value.integer, result->value.integer,
- gfc_unsigned_kinds[k].huge);
-
+ gfc_reduce_unsigned (result);
return result;
}
@@ -2540,7 +2554,6 @@ gfc_real2uint (gfc_expr *src, int kind)
gfc_expr *result;
arith rc;
bool did_warn = false;
- int k;
if (src->ts.type != BT_REAL)
return NULL;
@@ -2555,9 +2568,7 @@ gfc_real2uint (gfc_expr *src, int kind)
return NULL;
}
- k = gfc_validate_kind (BT_UNSIGNED, kind, false);
- mpz_and (result->value.integer, result->value.integer,
- gfc_unsigned_kinds[k].huge);
+ gfc_reduce_unsigned (result);
/* If there was a fractional part, warn about this. */
@@ -2774,7 +2785,6 @@ gfc_complex2uint (gfc_expr *src, int kind)
gfc_expr *result;
arith rc;
bool did_warn = false;
- int k;
if (src->ts.type != BT_COMPLEX)
return NULL;
@@ -2791,9 +2801,7 @@ gfc_complex2uint (gfc_expr *src, int kind)
return NULL;
}
- k = gfc_validate_kind (BT_UNSIGNED, kind, false);
- mpz_and (result->value.integer, result->value.integer,
- gfc_unsigned_kinds[k].huge);
+ gfc_reduce_unsigned (result);
if (warn_conversion || warn_conversion_extra)
{
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 360d06f2532c..5cfae6182c3b 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -524,6 +524,20 @@ type_check (gfc_expr *e, int n, bt type)
return false;
}
+/* Check the type of an expression which can be one of two. */
+
+static bool
+type_check2 (gfc_expr *e, int n, bt type1, bt type2)
+{
+ if (e->ts.type == type1 || e->ts.type == type2)
+ return true;
+
+ gfc_error ("%qs argument of %qs intrinsic at %L must be %s or %s",
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where, gfc_basic_typename (type1), gfc_basic_typename (type2));
+
+ return false;
+}
/* Check that the expression is a numeric type. */
@@ -575,6 +589,23 @@ int_or_real_check (gfc_expr *e, int n)
return true;
}
+/* Check that an expression is integer or real... or unsigned. */
+
+static bool
+int_or_real_or_unsigned_check (gfc_expr *e, int n)
+{
+ if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
+ && e->ts.type != BT_UNSIGNED)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
+ "REAL or UNSIGNED", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &e->where);
+ return false;
+ }
+
+ return true;
+}
+
/* Check that an expression is integer or real; allow character for
F2003 or later. */
@@ -2669,7 +2700,13 @@ gfc_check_dble (gfc_expr *x)
bool
gfc_check_digits (gfc_expr *x)
{
- if (!int_or_real_check (x, 0))
+
+ if (flag_unsigned)
+ {
+ if (!int_or_real_or_unsigned_check (x, 0))
+ return false;
+ }
+ else if (!int_or_real_check (x, 0))
return false;
return true;
@@ -3049,7 +3086,12 @@ gfc_check_fnum (gfc_expr *unit)
bool
gfc_check_huge (gfc_expr *x)
{
- if (!int_or_real_check (x, 0))
+ if (flag_unsigned)
+ {
+ if (!int_or_real_or_unsigned_check (x, 0))
+ return false;
+ }
+ else if (!int_or_real_check (x, 0))
return false;
return true;
@@ -3079,6 +3121,21 @@ gfc_check_i (gfc_expr *i)
return true;
}
+/* Check that the single argument is an integer or an UNSIGNED. */
+
+bool
+gfc_check_iu (gfc_expr *i)
+{
+ if (flag_unsigned)
+ {
+ if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+ return false;
+ }
+ else if (!type_check (i, 0, BT_INTEGER))
+ return false;
+
+ return true;
+}
bool
gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
@@ -3097,12 +3154,37 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
&& !gfc_boz2int (j, i->ts.kind))
return false;
- if (!type_check (i, 0, BT_INTEGER))
+ /* If i is BOZ and j is UNSIGNED, convert i to type of j. */
+ if (i->ts.type == BT_BOZ && j->ts.type == BT_UNSIGNED
+ && !gfc_boz2uint (i, j->ts.kind))
return false;
- if (!type_check (j, 1, BT_INTEGER))
+ /* If j is BOZ and i is UNSIGNED, convert j to type of i. */
+ if (j->ts.type == BT_BOZ && i->ts.type == BT_UNSIGNED
+ && !gfc_boz2uint (j, i->ts.kind))
return false;
+ if (flag_unsigned)
+ {
+ if (gfc_invalid_unsigned_ops (i,j))
+ return false;
+
+ 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;
+ }
+
if (i->ts.kind != j->ts.kind)
{
gfc_error ("Arguments of %qs have different kind type parameters "
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index e3567cd0d18f..5f8dd1300a50 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3474,6 +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);
extern bool gfc_seen_div0;
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 86f5ce9f1e32..8dcdff9540a5 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -2747,7 +2747,7 @@ add_functions (void)
make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_F95,
- gfc_check_i, gfc_simplify_not, gfc_resolve_not,
+ gfc_check_iu, gfc_simplify_not, gfc_resolve_not,
i, BT_INTEGER, di, REQUIRED);
if (flag_dec_intrinsic_ints)
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index fcb2733ddec8..653a17fd9b9f 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -89,6 +89,7 @@ bool gfc_check_hostnm (gfc_expr *);
bool gfc_check_huge (gfc_expr *);
bool gfc_check_hypot (gfc_expr *, gfc_expr *);
bool gfc_check_i (gfc_expr *);
+bool gfc_check_iu (gfc_expr *);
bool gfc_check_iand_ieor_ior (gfc_expr *, gfc_expr *);
bool gfc_check_and (gfc_expr *, gfc_expr *);
bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 8f70acf84ca0..dca383ebd19f 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -4458,6 +4458,15 @@ resolve_operator (gfc_expr *e)
goto bad_op;
}
+ if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
+ {
+ dual_locus_error = true;
+ snprintf (msg, sizeof (msg),
+ _("Inconsistent types for operator at %%L and %%L: "
+ "%s and %s"), gfc_typename (op1), gfc_typename (op2));
+ goto bad_op;
+ }
+
gfc_type_convert_binary (e, 1);
e->ts.type = BT_LOGICAL;
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 5bedab3f3f4d..e00ebb6e4d19 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -2356,6 +2356,10 @@ gfc_simplify_digits (gfc_expr *x)
digits = gfc_integer_kinds[i].digits;
break;
+ case BT_UNSIGNED:
+ digits = gfc_unsigned_kinds[i].digits;
+ break;
+
case BT_REAL:
case BT_COMPLEX:
digits = gfc_real_kinds[i].digits;
@@ -3265,7 +3269,11 @@ gfc_simplify_huge (gfc_expr *e)
mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
break;
- case BT_REAL:
+ case BT_UNSIGNED:
+ mpz_set (result->value.integer, gfc_unsigned_kinds[i].huge);
+ break;
+
+ case BT_REAL:
mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
break;
@@ -3369,11 +3377,13 @@ gfc_expr *
gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
+ bt type;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+ type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
+ result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
mpz_and (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IAND");
@@ -3547,11 +3557,13 @@ gfc_expr *
gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
+ bt type;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+ type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
+ result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IEOR");
@@ -3774,11 +3786,13 @@ gfc_expr *
gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
+ bt type;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+ type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
+ result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IOR");
diff --git a/gcc/testsuite/gfortran.dg/unsigned_7.f90
b/gcc/testsuite/gfortran.dg/unsigned_7.f90
new file mode 100644
index 000000000000..703c8abcbf79
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_7.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test bit functions, huge and digits.
+ unsigned :: u1, u2, u3
+ u1 = 32u
+ u2 = 64u
+ if (ior (u1,u2) /= u1 + u2) error stop 1
+ if (ior (32u,64u) /= 32u + 64u) error stop 2
+ u1 = 234u
+ u2 = 221u
+ if (iand (u1,u2) /= 200u) error stop 3
+ if (iand (234u,221u) /= 200u) error stop 4
+ if (ieor (u1,u2) /= 55u) error stop 5
+ if (ieor (234u,221u) /= 55u) error stop 6
+ u1 = huge(u1)
+ if (u1 /= 4294967295u) error stop 7
+ u2 = not(0u)
+ u3 = u2 - u1
+ if (u3 /= 0u) error stop 8
+ u2 = not(255u);
+ if (u2 /= huge(u2) - 255u) error stop 9
+ u1 = 255u
+ u2 = not(u1)
+ if (u2 /= huge(u2) - 255u) error stop 9
+ if (digits(u1) /= 32) error stop 10
+end
