https://gcc.gnu.org/g:74cc1893acada349114d17f65909c0f0c293061c
commit 74cc1893acada349114d17f65909c0f0c293061c
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Thu Aug 1 20:53:59 2024 +0200
A few fixes, add unsigned truncation warning.
Diff:
---
gcc/fortran/arith.cc | 62 +++++++++++++++++++++++++++++---
gcc/fortran/gfortran.h | 9 +++--
gcc/fortran/primary.cc | 7 ++++
gcc/fortran/simplify.cc | 6 ++--
gcc/fortran/trans-types.cc | 50 ++++++++++++++++++--------
gcc/testsuite/gfortran.dg/unsigned_3.f90 | 10 ++++++
6 files changed, 119 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index 849fa784241d..1b304b114dd8 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -86,7 +86,7 @@ gfc_set_model (mpfr_t x)
/* Given an arithmetic error code, return a pointer to a string that
explains the error. */
-static const char *
+const char *
gfc_arith_error (arith code)
{
const char *p;
@@ -121,7 +121,12 @@ gfc_arith_error (arith code)
case ARITH_INVALID_TYPE:
p = G_("Invalid type in arithmetic operation at %L");
break;
-
+ case ARITH_UNSIGNED_TRUNCATED:
+ p = G_("Unsigned constant truncated at %L");
+ break;
+ case ARITH_UNSIGNED_NEGATIVE:
+ p = G_("Truncated negative unsigned constant at %L");
+ break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
}
@@ -208,13 +213,21 @@ gfc_arith_init_1 (void)
{
for (uint_info = gfc_unsigned_kinds; uint_info->kind != 0; uint_info++)
{
+ /* UNSIGNED is radix 2. */
+ gcc_assert (uint_info->radix == 2);
/* Huge. */
mpz_init (uint_info->huge);
- mpz_set_ui (uint_info->huge, uint_info->radix);
+ mpz_set_ui (uint_info->huge, 2);
mpz_pow_ui (uint_info->huge, uint_info->huge, uint_info->digits);
+ mpz_sub_ui (uint_info->huge, uint_info->huge, 1);
- /* UNSIGNED is radix 2. */
- gcc_assert (uint_info->radix == 2);
+ /* int_min - the smallest number we can reasonably convert from. */
+
+ mpz_init (uint_info->int_min);
+ mpz_set_ui (uint_info->int_min, 2);
+ mpz_pow_ui (uint_info->int_min, uint_info->int_min,
+ uint_info->digits - 1);
+ mpz_neg (uint_info->int_min, uint_info->int_min);
/* Range. */
mpfr_set_z (a, uint_info->huge, GFC_RND_MODE);
@@ -367,6 +380,24 @@ gfc_check_integer_range (mpz_t p, int kind)
return result;
}
+/* Same as above. */
+arith
+gfc_check_unsigned_range (mpz_t p, int kind)
+{
+ arith result;
+ int i;
+
+ i = gfc_validate_kind (BT_UNSIGNED, kind, false);
+ result = ARITH_OK;
+
+ if (mpz_cmp (p, gfc_unsigned_kinds[i].int_min) < 0)
+ result = ARITH_UNSIGNED_TRUNCATED;
+
+ if (mpz_cmp (p, gfc_unsigned_kinds[i].huge) > 0)
+ result = ARITH_UNSIGNED_TRUNCATED;
+
+ return result;
+}
/* Given a real and a kind, make sure that the real lies within the
range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
@@ -564,6 +595,10 @@ gfc_range_check (gfc_expr *e)
rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
break;
+ case BT_UNSIGNED:
+ rc = gfc_check_unsigned_range (e->value.integer, e->ts.kind);
+ break;
+
case BT_REAL:
rc = gfc_check_real_range (e->value.real, e->ts.kind);
if (rc == ARITH_UNDERFLOW)
@@ -653,6 +688,7 @@ 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);
@@ -662,6 +698,22 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
mpz_neg (result->value.integer, op1->value.integer);
break;
+ case BT_UNSIGNED:
+ {
+ 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);
+ if (pedantic)
+ rc = neg_rc;
+ }
+ break;
+
case BT_REAL:
mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
break;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1e3262f97bf2..b241e2834b9b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -227,7 +227,8 @@ enum gfc_intrinsic_op
enum arith
{ ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, ARITH_NAN,
ARITH_DIV0, ARITH_INCOMMENSURATE, ARITH_ASYMMETRIC, ARITH_PROHIBIT,
- ARITH_WRONGCONCAT, ARITH_INVALID_TYPE, ARITH_NOT_REDUCED
+ ARITH_WRONGCONCAT, ARITH_INVALID_TYPE, ARITH_NOT_REDUCED,
+ ARITH_UNSIGNED_TRUNCATED, ARITH_UNSIGNED_NEGATIVE
};
/* Statements. */
@@ -2744,7 +2745,7 @@ extern gfc_integer_info gfc_integer_kinds[];
typedef struct
{
- mpz_t huge;
+ mpz_t huge, int_min;
int kind, radix, digits, bit_size, range;
@@ -3470,7 +3471,9 @@ void gfc_errors_to_warnings (bool);
void gfc_arith_init_1 (void);
void gfc_arith_done_1 (void);
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);
extern bool gfc_seen_div0;
@@ -4112,7 +4115,7 @@ void gfc_convert_mpz_to_signed (mpz_t, int);
gfc_expr *gfc_simplify_ieee_functions (gfc_expr *);
bool gfc_is_constant_array_expr (gfc_expr *);
bool gfc_is_size_zero_array (gfc_expr *);
-void gfc_convert_mpz_to_unsigned (mpz_t, int, bool check = true);
+void gfc_convert_mpz_to_unsigned (mpz_t, int, bool sign = true);
/* trans-array.cc */
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 63b0bcf6784d..24bfdb55e41d 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -218,6 +218,7 @@ convert_unsigned (const char *buffer, int kind, int radix,
locus *where)
gfc_expr *e;
const char *t;
int k;
+ arith rc;
e = gfc_get_constant_expr (BT_UNSIGNED, kind, where);
/* A leading plus is allowed, but not by mpz_set_str. */
@@ -229,6 +230,12 @@ convert_unsigned (const char *buffer, int kind, int radix,
locus *where)
mpz_set_str (e->value.integer, t, radix);
k = gfc_validate_kind (BT_UNSIGNED, kind, false);
+
+ /* XXX Maybe move this somewhere else. */
+ rc = gfc_range_check (e);
+ if (rc != ARITH_OK)
+ gfc_warning (0, gfc_arith_error (rc), &e->where);
+
gfc_convert_mpz_to_unsigned (e->value.integer,
gfc_unsigned_kinds[k].bit_size,
false);
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index a8c9397edf97..919d9d560e11 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -148,7 +148,7 @@ get_kind (bt type, gfc_expr *k, const char *name, int
default_kind)
be accomplished by masking out the high bits. */
void
-gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool check)
+gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool sign)
{
mpz_t mask;
@@ -156,7 +156,7 @@ gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool
check)
{
/* Confirm that no bits above the signed range are unset if we
are doing range checking. */
- if (flag_range_check != 0)
+ if (sign && flag_range_check != 0)
gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
mpz_init_set_ui (mask, 1);
@@ -171,7 +171,7 @@ gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool
check)
{
/* Confirm that no bits above the signed range are set if we
are doing range checking. */
- if (check && flag_range_check != 0)
+ if (sign && flag_range_check != 0)
gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
}
}
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index a00dc80bf596..552e46dcc8ca 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1038,18 +1038,6 @@ gfc_init_types (void)
PUSH_TYPE (name_buf, type);
}
- if (flag_unsigned)
- {
- for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index)
- {
- type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]);
- gfc_unsigned_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d",
- gfc_integer_kinds[index].kind);
- PUSH_TYPE (name_buf, type);
- }
- }
-
for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
{
type = gfc_build_logical_type (&gfc_logical_kinds[index]);
@@ -1092,6 +1080,40 @@ gfc_init_types (void)
}
gfc_character1_type_node = gfc_character_types[0];
+ /* The middle end only recognizes a single unsigned type. For
+ compatibility of existing test cases, let's just use the
+ character type. The reader of tree dumps is expected to be able
+ to deal with this. */
+
+ if (flag_unsigned)
+ {
+ for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index)
+ {
+ int index_char = -1;
+ for (int i=0; gfc_character_kinds[i].kind != 0; i++)
+ {
+ if (gfc_character_kinds[i].bit_size ==
+ gfc_unsigned_kinds[index].bit_size)
+ {
+ index_char = i;
+ break;
+ }
+ }
+ if (index_char > 0)
+ {
+ gfc_unsigned_types[index] = gfc_character_types[index_char];
+ }
+ else
+ {
+ type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]);
+ gfc_unsigned_types[index] = type;
+ snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)",
+ gfc_integer_kinds[index].kind);
+ PUSH_TYPE (name_buf, type);
+ }
+ }
+ }
+
PUSH_TYPE ("byte", unsigned_char_type_node);
PUSH_TYPE ("void", void_type_node);
@@ -1153,8 +1175,8 @@ gfc_get_int_type (int kind)
tree
gfc_get_unsigned_type (int kind)
{
- int index = gfc_validate_kind (BT_INTEGER, kind, true);
- return index < 0 ? 0 : gfc_integer_types[index];
+ int index = gfc_validate_kind (BT_UNSIGNED, kind, true);
+ return index < 0 ? 0 : gfc_unsigned_types[index];
}
tree
diff --git a/gcc/testsuite/gfortran.dg/unsigned_3.f90
b/gcc/testsuite/gfortran.dg/unsigned_3.f90
new file mode 100644
index 000000000000..7d5b4d67cfd3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_3.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-funsigned" }
+! Test that overflow warned about.
+program main
+ unsigned(1) :: u
+ u = 256u_1 ! { dg-warning "Unsigned constant truncated" }
+ u = -127u_1
+ u = 255u_1
+ u = -129u_1 ! { dg-warning "Unsigned constant truncated" }
+end
