https://gcc.gnu.org/g:11b09c5f9babc07d72ae3e07cbdeb11286c881b4
commit 11b09c5f9babc07d72ae3e07cbdeb11286c881b4
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Sun Aug 4 20:14:34 2024 +0200
Add bit_size, btest and bgt plus friends.
Diff:
---
gcc/fortran/check.cc | 66 ++++++++++++++++++++++--------
gcc/fortran/intrinsic.cc | 2 +-
gcc/fortran/simplify.cc | 47 +++++++++++++++++----
gcc/testsuite/gfortran.dg/unsigned_8.f90 | 70 ++++++++++++++++++++++++++++++++
4 files changed, 160 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 5cfae6182c3b..1a8f601ce838 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -2015,11 +2015,36 @@ gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
&& !gfc_boz2int (j, i->ts.kind))
return false;
- if (!type_check (i, 0, BT_INTEGER))
- return false;
+ if (flag_unsigned)
+ {
+ /* 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))
- return false;
+ /* 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 (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;
+ }
return true;
}
@@ -2028,8 +2053,16 @@ gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
bool
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
{
- 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;
@@ -3154,18 +3187,18 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
&& !gfc_boz2int (j, i->ts.kind))
return false;
- /* 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 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 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 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 (gfc_invalid_unsigned_ops (i,j))
return false;
@@ -3177,7 +3210,6 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
}
else
{
-
if (!type_check (i, 0, BT_INTEGER))
return false;
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 8dcdff9540a5..da4e9828dc8d 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -1661,7 +1661,7 @@ add_functions (void)
make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008);
add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
- gfc_check_i, gfc_simplify_bit_size, NULL,
+ gfc_check_iu, gfc_simplify_bit_size, NULL,
i, BT_INTEGER, di, REQUIRED);
make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index e00ebb6e4d19..1818dc5956cc 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -1658,8 +1658,14 @@ gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- return gfc_get_int_expr (e->ts.kind, &e->where,
- gfc_integer_kinds[i].bit_size);
+ int bit_size;
+
+ if (flag_unsigned && e->ts.type == BT_UNSIGNED)
+ bit_size = gfc_unsigned_kinds[i].bit_size;
+ else
+ bit_size = gfc_integer_kinds[i].bit_size;
+
+ return gfc_get_int_expr (e->ts.kind, &e->where, bit_size);
}
@@ -1709,47 +1715,74 @@ compare_bitwise (gfc_expr *i, gfc_expr *j)
gfc_expr *
gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
{
+ bool result;
+
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
+ if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+ result = mpz_cmp (i->value.integer, j->value.integer) >= 0;
+ else
+ result = compare_bitwise (i, j) >= 0;
+
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
- compare_bitwise (i, j) >= 0);
+ result);
}
gfc_expr *
gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
{
+ bool result;
+
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
+ if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+ result = mpz_cmp (i->value.integer, j->value.integer) > 0;
+ else
+ result = compare_bitwise (i, j) > 0;
+
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
- compare_bitwise (i, j) > 0);
+ result);
}
gfc_expr *
gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
{
+ bool result;
+
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
+ if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+ result = mpz_cmp (i->value.integer, j->value.integer) <= 0;
+ else
+ result = compare_bitwise (i, j) <= 0;
+
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
- compare_bitwise (i, j) <= 0);
+ result);
}
gfc_expr *
gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
{
+ bool result;
+
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
+ if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+ result = mpz_cmp (i->value.integer, j->value.integer) < 0;
+ else
+ result = compare_bitwise (i, j) < 0;
+
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
- compare_bitwise (i, j) < 0);
+ result);
}
-
gfc_expr *
gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
diff --git a/gcc/testsuite/gfortran.dg/unsigned_8.f90
b/gcc/testsuite/gfortran.dg/unsigned_8.f90
new file mode 100644
index 000000000000..f23056ab3bb9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_8.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test bit_size, btest and bgt plus friends.
+program main
+ implicit none
+ unsigned :: u
+ integer :: i, j
+ unsigned :: ui, uj
+ logical:: test_i, test_u
+ if (bit_size(u) /= 32) error stop 1
+ if (.not. btest(32,5)) error stop 2
+ if (btest(32,4)) error stop 3
+ u = 32u
+ if (btest(u,4)) error stop 4
+ do i=1,3
+ ui = uint(i)
+ do j=1,3
+ uj = uint(j)
+ test_i = blt(i,j)
+ test_u = blt(ui,uj)
+ if (test_i .neqv. test_u) error stop 5
+ test_i = ble(i,j)
+ test_u = ble(ui,uj)
+ if (test_i .neqv. test_u) error stop 6
+ test_i = bge(i,j)
+ test_u = bge(ui,uj)
+ if (test_i .neqv. test_u) error stop 7
+ test_i = bgt(i,j)
+ test_u = bgt(ui,uj)
+ if (test_i .neqv. test_u) error stop 8
+ end do
+ end do
+ if (blt (1, 1) .neqv. blt (1u, 1u)) error stop 8
+ if (ble (1, 1) .neqv. ble (1u, 1u)) error stop 9
+ if (bge (1, 1) .neqv. bge (1u, 1u)) error stop 10
+ if (bgt (1, 1) .neqv. bgt (1u, 1u)) error stop 11
+ if (blt (1, 2) .neqv. blt (1u, 2u)) error stop 12
+ if (ble (1, 2) .neqv. ble (1u, 2u)) error stop 13
+ if (bge (1, 2) .neqv. bge (1u, 2u)) error stop 14
+ if (bgt (1, 2) .neqv. bgt (1u, 2u)) error stop 15
+ if (blt (1, 3) .neqv. blt (1u, 3u)) error stop 16
+ if (ble (1, 3) .neqv. ble (1u, 3u)) error stop 17
+ if (bge (1, 3) .neqv. bge (1u, 3u)) error stop 18
+ if (bgt (1, 3) .neqv. bgt (1u, 3u)) error stop 19
+ if (blt (2, 1) .neqv. blt (2u, 1u)) error stop 20
+ if (ble (2, 1) .neqv. ble (2u, 1u)) error stop 21
+ if (bge (2, 1) .neqv. bge (2u, 1u)) error stop 22
+ if (bgt (2, 1) .neqv. bgt (2u, 1u)) error stop 23
+ if (blt (2, 2) .neqv. blt (2u, 2u)) error stop 24
+ if (ble (2, 2) .neqv. ble (2u, 2u)) error stop 25
+ if (bge (2, 2) .neqv. bge (2u, 2u)) error stop 26
+ if (bgt (2, 2) .neqv. bgt (2u, 2u)) error stop 27
+ if (blt (2, 3) .neqv. blt (2u, 3u)) error stop 28
+ if (ble (2, 3) .neqv. ble (2u, 3u)) error stop 29
+ if (bge (2, 3) .neqv. bge (2u, 3u)) error stop 30
+ if (bgt (2, 3) .neqv. bgt (2u, 3u)) error stop 31
+ if (blt (3, 1) .neqv. blt (3u, 1u)) error stop 32
+ if (ble (3, 1) .neqv. ble (3u, 1u)) error stop 33
+ if (bge (3, 1) .neqv. bge (3u, 1u)) error stop 34
+ if (bgt (3, 1) .neqv. bgt (3u, 1u)) error stop 35
+ if (blt (3, 2) .neqv. blt (3u, 2u)) error stop 36
+ if (ble (3, 2) .neqv. ble (3u, 2u)) error stop 37
+ if (bge (3, 2) .neqv. bge (3u, 2u)) error stop 38
+ if (bgt (3, 2) .neqv. bgt (3u, 2u)) error stop 39
+ if (blt (3, 3) .neqv. blt (3u, 3u)) error stop 40
+ if (ble (3, 3) .neqv. ble (3u, 3u)) error stop 41
+ if (bge (3, 3) .neqv. bge (3u, 3u)) error stop 42
+ if (bgt (3, 3) .neqv. bgt (3u, 3u)) error stop 43
+
+end
