@@ -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
@@ -86,7 +95,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 +130,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_("Negation of unsigned constant at %L not permitted");
+ break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
}
@@ -160,6 +174,7 @@ void
gfc_arith_init_1 (void)
{
gfc_integer_info *int_info;
+ gfc_unsigned_info *uint_info;
gfc_real_info *real_info;
mpfr_t a, b;
int i;
@@ -202,6 +217,36 @@ gfc_arith_init_1 (void)
int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
}
+ /* Similar, for UNSIGNED. */
+ if (flag_unsigned)
+ {
+ 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, 2);
+ mpz_pow_ui (uint_info->huge, uint_info->huge, uint_info->digits);
+ mpz_sub_ui (uint_info->huge, uint_info->huge, 1);
+
+ /* 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);
+ mpfr_log10 (a, a, GFC_RND_MODE);
+ mpfr_trunc (a,a);
+ uint_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
+ }
+
+ }
+
mpfr_clear (a);
for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
@@ -344,6 +389,25 @@ gfc_check_integer_range (mpz_t p, int kind)
return result;
}
+/* Same as above. */
+arith
+gfc_check_unsigned_range (mpz_t p, int kind)
+{
+ int i;
+
+ i = gfc_validate_kind (BT_UNSIGNED, kind, false);
+
+ if (pedantic && mpz_cmp_si (p, 0) < 0)
+ return ARITH_UNSIGNED_NEGATIVE;
+
+ if (mpz_cmp (p, gfc_unsigned_kinds[i].int_min) < 0)
+ return ARITH_UNSIGNED_TRUNCATED;
+
+ if (mpz_cmp (p, gfc_unsigned_kinds[i].huge) > 0)
+ return ARITH_UNSIGNED_TRUNCATED;
+
+ return ARITH_OK;
+}
/* Given a real and a kind, make sure that the real lies within the
range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or
@@ -541,6 +605,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)
@@ -639,6 +707,23 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
mpz_neg (result->value.integer, op1->value.integer);
break;
+ case BT_UNSIGNED:
+ {
+ if (pedantic)
+ return ARITH_UNSIGNED_NEGATIVE;
+
+ arith neg_rc;
+ mpz_neg (result->value.integer, op1->value.integer);
+ neg_rc = gfc_range_check (result);
+ if (neg_rc != ARITH_OK)
+ gfc_warning (0, gfc_arith_error (neg_rc), &result->where);
+
+ gfc_reduce_unsigned (result);
+ if (pedantic)
+ rc = neg_rc;
+ }
+ break;
+
case BT_REAL:
mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
break;
@@ -674,6 +759,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);
@@ -708,6 +798,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;
@@ -748,6 +839,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);
@@ -785,6 +881,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;
@@ -1131,6 +1228,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
switch (op1->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
rc = mpz_cmp (op1->value.integer, op2->value.integer);
break;
@@ -1719,14 +1817,25 @@ eval_intrinsic (gfc_intrinsic_op op,
gcc_fallthrough ();
/* Numeric binary */
+ case INTRINSIC_POWER:
+ if (flag_unsigned && op == INTRINSIC_POWER)
+ {
+ if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED)
+ goto runtime;
+ }
+
+ gcc_fallthrough();
+
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
- case INTRINSIC_POWER:
if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
goto runtime;
+ if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
+ goto runtime;
+
/* Do not perform conversions if operands are not conformable as
required for the binary intrinsic operators (F2018:10.1.5).
Defer to a possibly overloading user-defined operator. */
@@ -2172,7 +2281,8 @@ wprecision_int_real (mpz_t n, mpfr_t r)
return ret;
}
-/* Convert integers to integers. */
+/* Convert integers to integers; we can reuse this for also converting
+ unsigneds. */
gfc_expr *
gfc_int2int (gfc_expr *src, int kind)
@@ -2180,7 +2290,7 @@ gfc_int2int (gfc_expr *src, int kind)
gfc_expr *result;
arith rc;
- if (src->ts.type != BT_INTEGER)
+ if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
return NULL;
result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
@@ -2289,6 +2399,109 @@ gfc_int2complex (gfc_expr *src, int kind)
return result;
}
+/* Convert unsigned to unsigned, or integer to unsigned. */
+
+gfc_expr *
+gfc_uint2uint (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ arith rc;
+
+ if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
+ mpz_set (result->value.integer, src->value.integer);
+
+ rc = gfc_range_check (result);
+ if (rc != ARITH_OK)
+ gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
+
+ gfc_reduce_unsigned (result);
+ return result;
+}
+
+gfc_expr *
+gfc_int2uint (gfc_expr *src, int kind)
+{
+ return gfc_uint2uint (src, kind);
+}
+
+gfc_expr *
+gfc_uint2int (gfc_expr *src, int kind)
+{
+ return gfc_int2int (src, kind);
+}
+
+/* Convert UNSIGNED to reals. */
+
+gfc_expr *
+gfc_uint2real (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ arith rc;
+
+ if (src->ts.type != BT_UNSIGNED)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+ mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
+
+ if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
+ {
+ /* This should be rare, just in case. */
+ arith_error (rc, &src->ts, &result->ts, &src->where);
+ gfc_free_expr (result);
+ return NULL;
+ }
+
+ if (warn_conversion
+ && wprecision_int_real (src->value.integer, result->value.real))
+ gfc_warning (OPT_Wconversion, "Change of value in conversion "
+ "from %qs to %qs at %L",
+ gfc_typename (&src->ts),
+ gfc_typename (&result->ts),
+ &src->where);
+
+ return result;
+}
+
+/* Convert default integer to default complex. */
+
+gfc_expr *
+gfc_uint2complex (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ arith rc;
+
+ if (src->ts.type != BT_UNSIGNED)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+ mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
+
+ if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
+ != ARITH_OK)
+ {
+ /* This should be rare, just in case. */
+ arith_error (rc, &src->ts, &result->ts, &src->where);
+ gfc_free_expr (result);
+ return NULL;
+ }
+
+ if (warn_conversion
+ && wprecision_int_real (src->value.integer,
+ mpc_realref (result->value.complex)))
+ gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
+ "from %qs to %qs at %L",
+ gfc_typename (&src->ts),
+ gfc_typename (&result->ts),
+ &src->where);
+
+ return result;
+}
/* Convert default real to default integer. */
@@ -2339,6 +2552,51 @@ gfc_real2int (gfc_expr *src, int kind)
return result;
}
+/* Convert real to unsigned. */
+
+gfc_expr *
+gfc_real2uint (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ arith rc;
+ bool did_warn = false;
+
+ if (src->ts.type != BT_REAL)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
+
+ gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
+ if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
+ gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
+
+ gfc_reduce_unsigned (result);
+
+ /* If there was a fractional part, warn about this. */
+
+ if (warn_conversion)
+ {
+ mpfr_t f;
+ mpfr_init (f);
+ mpfr_frac (f, src->value.real, GFC_RND_MODE);
+ if (mpfr_cmp_si (f, 0) != 0)
+ {
+ gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
+ "from %qs to %qs at %L", gfc_typename (&src->ts),
+ gfc_typename (&result->ts), &src->where);
+ did_warn = true;
+ }
+ mpfr_clear (f);
+ }
+ if (!did_warn && warn_conversion_extra)
+ {
+ gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
+ "at %L", gfc_typename (&src->ts),
+ gfc_typename (&result->ts), &src->where);
+ }
+
+ return result;
+}
/* Convert real to real. */
@@ -2521,6 +2779,68 @@ gfc_complex2int (gfc_expr *src, int kind)
return result;
}
+/* Convert complex to integer. */
+
+gfc_expr *
+gfc_complex2uint (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+ arith rc;
+ bool did_warn = false;
+
+ if (src->ts.type != BT_COMPLEX)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
+
+ gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
+ &src->where);
+
+ if ((rc = gfc_check_unsigned_range (result->value.integer, kind)) != ARITH_OK)
+ gfc_warning (OPT_Wconversion, gfc_arith_error (rc), &result->where);
+
+ gfc_reduce_unsigned (result);
+
+ if (warn_conversion || warn_conversion_extra)
+ {
+ int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
+
+ /* See if we discarded an imaginary part. */
+ if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
+ {
+ gfc_warning_now (w, "Non-zero imaginary part discarded "
+ "in conversion from %qs to %qs at %L",
+ gfc_typename(&src->ts), gfc_typename (&result->ts),
+ &src->where);
+ did_warn = true;
+ }
+
+ else {
+ mpfr_t f;
+
+ mpfr_init (f);
+ mpfr_frac (f, src->value.real, GFC_RND_MODE);
+ if (mpfr_cmp_si (f, 0) != 0)
+ {
+ gfc_warning_now (w, "Change of value in conversion from "
+ "%qs to %qs at %L", gfc_typename (&src->ts),
+ gfc_typename (&result->ts), &src->where);
+ did_warn = true;
+ }
+ mpfr_clear (f);
+ }
+
+ if (!did_warn && warn_conversion_extra)
+ {
+ gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
+ "at %L", gfc_typename (&src->ts),
+ gfc_typename (&result->ts), &src->where);
+ }
+ }
+
+ return result;
+}
+
/* Convert complex to real. */
@@ -2695,6 +3015,22 @@ gfc_log2int (gfc_expr *src, int kind)
return result;
}
+/* Convert logical to unsigned. */
+
+gfc_expr *
+gfc_log2uint (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+
+ if (src->ts.type != BT_LOGICAL)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
+ mpz_set_si (result->value.integer, src->value.logical);
+
+ return result;
+}
+
/* Convert integer to logical. */
@@ -2712,6 +3048,22 @@ gfc_int2log (gfc_expr *src, int kind)
return result;
}
+/* Convert unsigned to logical. */
+
+gfc_expr *
+gfc_uint2log (gfc_expr *src, int kind)
+{
+ gfc_expr *result;
+
+ if (src->ts.type != BT_UNSIGNED)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
+ result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
+
+ return result;
+}
+
/* Convert character to character. We only use wide strings internally,
so we only set the kind. */
@@ -63,15 +63,24 @@ gfc_expr *gfc_le (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_int2int (gfc_expr *, int);
gfc_expr *gfc_int2real (gfc_expr *, int);
gfc_expr *gfc_int2complex (gfc_expr *, int);
+gfc_expr *gfc_int2uint (gfc_expr *, int);
+gfc_expr *gfc_uint2uint (gfc_expr *, int);
+gfc_expr *gfc_uint2int (gfc_expr *, int);
+gfc_expr *gfc_uint2real (gfc_expr *, int);
+gfc_expr *gfc_uint2complex (gfc_expr *, int);
gfc_expr *gfc_real2int (gfc_expr *, int);
+gfc_expr *gfc_real2uint (gfc_expr *, int);
gfc_expr *gfc_real2real (gfc_expr *, int);
gfc_expr *gfc_real2complex (gfc_expr *, int);
gfc_expr *gfc_complex2int (gfc_expr *, int);
+gfc_expr *gfc_complex2uint (gfc_expr *, int);
gfc_expr *gfc_complex2real (gfc_expr *, int);
gfc_expr *gfc_complex2complex (gfc_expr *, int);
gfc_expr *gfc_log2log (gfc_expr *, int);
gfc_expr *gfc_log2int (gfc_expr *, int);
+gfc_expr *gfc_log2uint (gfc_expr *, int);
gfc_expr *gfc_int2log (gfc_expr *, int);
+gfc_expr *gfc_uint2log (gfc_expr *, int);
gfc_expr *gfc_hollerith2int (gfc_expr *, int);
gfc_expr *gfc_hollerith2real (gfc_expr *, int);
gfc_expr *gfc_hollerith2complex (gfc_expr *, int);
@@ -465,7 +465,34 @@ gfc_boz2int (gfc_expr *x, int kind)
return true;
}
+/* Same as above for UNSIGNED, but much simpler because
+ of wraparound. */
+bool
+gfc_boz2uint (gfc_expr *x, int kind)
+{
+ int k;
+ if (!is_boz_constant(x))
+ return false;
+
+ mpz_init (x->value.integer);
+ mpz_set_str (x->value.integer, x->boz.str, x->boz.rdx);
+ k = gfc_validate_kind (BT_UNSIGNED, kind, false);
+ if (mpz_cmp (x->value.integer, gfc_unsigned_kinds[k].huge) > 0)
+ {
+ gfc_warning (0, _("BOZ contstant truncated at %L"), &x->where);
+ mpz_and (x->value.integer, x->value.integer, gfc_unsigned_kinds[k].huge);
+ }
+
+ x->ts.type = BT_UNSIGNED;
+ x->ts.kind = kind;
+ /* Clear boz info. */
+ x->boz.rdx = 0;
+ x->boz.len = 0;
+ free (x->boz.str);
+
+ return true;
+}
/* Make sure an expression is a scalar. */
static bool
@@ -497,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. */
@@ -548,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. */
@@ -855,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);
@@ -881,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)",
@@ -1408,7 +1479,6 @@ gfc_check_allocated (gfc_expr *array)
return true;
}
-
/* Common check function where the first argument must be real or
integer and the second argument must be the same as the first. */
@@ -1437,6 +1507,39 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p)
return true;
}
+/* Check function where the first argument must be real or integer (or
+ unsigned) and the second argument must be the same as the first. */
+
+bool
+gfc_check_mod (gfc_expr *a, gfc_expr *p)
+{
+ if (flag_unsigned)
+ {
+ if (!int_or_real_or_unsigned_check (a,0))
+ return false;
+ }
+ else if (!int_or_real_check (a, 0))
+ return false;
+
+ if (a->ts.type != p->ts.type)
+ {
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
+ "have the same type", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+ &p->where);
+ return false;
+ }
+
+ if (a->ts.kind != p->ts.kind)
+ {
+ if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
+ &p->where))
+ return false;
+ }
+
+ return true;
+}
+
bool
gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
@@ -1957,11 +2060,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;
}
@@ -1970,8 +2098,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;
@@ -2642,7 +2778,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;
@@ -2725,33 +2867,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;
@@ -3022,7 +3185,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;
@@ -3052,6 +3220,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)
@@ -3070,11 +3253,35 @@ 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))
- 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;
+ }
if (i->ts.kind != j->ts.kind)
{
@@ -3090,8 +3297,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;
@@ -3240,6 +3455,29 @@ gfc_check_int (gfc_expr *x, gfc_expr *kind)
return true;
}
+bool
+gfc_check_uint (gfc_expr *x, gfc_expr *kind)
+{
+
+ if (!flag_unsigned)
+ {
+ gfc_error ("UINT intrinsic only valid with %<-funsigned%> at %L",
+ &x->where);
+ return false;
+ }
+
+ /* BOZ is dealt within simplify_uint*. */
+ if (x->ts.type == BT_BOZ)
+ return true;
+
+ if (!numeric_check (x, 0))
+ return false;
+
+ if (!kind_check (kind, 1, BT_INTEGER))
+ return false;
+
+ return true;
+}
bool
gfc_check_intconv (gfc_expr *x)
@@ -3266,8 +3504,18 @@ gfc_check_intconv (gfc_expr *x)
bool
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
{
- if (!type_check (i, 0, BT_INTEGER)
- || !type_check (shift, 1, BT_INTEGER))
+ 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 (shift, 1, BT_INTEGER))
return false;
if (!less_than_bitsize1 ("I", i, NULL, shift, true))
@@ -3280,9 +3528,16 @@ gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
bool
gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
- if (!type_check (i, 0, BT_INTEGER)
- || !type_check (shift, 1, 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 (size != NULL)
{
@@ -3756,11 +4011,29 @@ gfc_check_min_max (gfc_actual_arglist *arg)
gfc_current_intrinsic, &x->where))
return false;
}
- else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ else
{
- gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
- "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
- return false;
+ if (flag_unsigned)
+ {
+ if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL
+ && x->ts.type != BT_UNSIGNED)
+ {
+ gfc_error ("%<a1%> argument of %qs intrinsic at %L must be "
+ "INTEGER, REAL, CHARACTER or UNSIGNED",
+ gfc_current_intrinsic, &x->where);
+ return false;
+ }
+ }
+ else
+ {
+ if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+ {
+ gfc_error ("%<a1%> argument of %qs intrinsic at %L must be "
+ "INTEGER, REAL or CHARACTER",
+ gfc_current_intrinsic, &x->where);
+ return false;
+ }
+ }
}
return check_rest (x->ts.type, x->ts.kind, arg);
@@ -4202,20 +4475,54 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
&& !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_boz2int (j, i->ts.kind))
+ 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 (!same_type_check (i, 0, j, 1))
return false;
- if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind))
- return false;
+ if (mask->ts.type == BT_BOZ)
+ {
+ if (i->ts.type == BT_INTEGER && !gfc_boz2int (mask, i->ts.kind))
+ return false;
+ if (i->ts.type == BT_UNSIGNED && !gfc_boz2uint (mask, i->ts.kind))
+ return false;
+ }
- if (!type_check (mask, 2, BT_INTEGER))
- return false;
+ if (flag_unsigned)
+ {
+ if (!type_check2 (mask, 2, BT_INTEGER, BT_UNSIGNED))
+ return false;
+ }
+ else
+ {
+ if (!type_check (mask, 2, BT_INTEGER))
+ return false;
+ }
if (!same_type_check (i, 0, mask, 2))
return false;
@@ -5012,7 +5319,6 @@ gfc_check_selected_int_kind (gfc_expr *r)
return true;
}
-
bool
gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
{
@@ -5108,8 +5414,16 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
bool
gfc_check_shift (gfc_expr *i, gfc_expr *shift)
{
- 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 (shift, 0, BT_INTEGER))
return false;
@@ -6604,8 +6918,17 @@ bool
gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
gfc_expr *to, gfc_expr *topos)
{
- if (!type_check (from, 0, BT_INTEGER))
- return false;
+
+ if (flag_unsigned)
+ {
+ if (!type_check2 (from, 0, BT_INTEGER, BT_UNSIGNED))
+ return false;
+ }
+ else
+ {
+ if (!type_check (from, 0, BT_INTEGER))
+ return false;
+ }
if (!type_check (frompos, 1, BT_INTEGER))
return false;
@@ -7637,3 +7960,12 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
return true;
}
+
+/* Check two operands that either both or none of them can
+ be UNSIGNED. */
+
+bool
+gfc_invalid_unsigned_ops (gfc_expr * op1, gfc_expr * op2)
+{
+ return (op1->ts.type == BT_UNSIGNED) + (op2->ts.type == BT_UNSIGNED) == 1;
+}
@@ -4342,6 +4342,17 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
goto get_kind;
}
+ if (flag_unsigned)
+ {
+ if ((matched_type && strcmp ("unsigned", name) == 0)
+ || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
+ {
+ ts->type = BT_UNSIGNED;
+ ts->kind = gfc_default_integer_kind;
+ goto get_kind;
+ }
+ }
+
if ((matched_type && strcmp ("character", name) == 0)
|| (!matched_type && gfc_match (" character") == MATCH_YES))
{
@@ -563,6 +563,14 @@ show_expr (gfc_expr *p)
fprintf (dumpfile, "_%d", p->ts.kind);
break;
+ case BT_UNSIGNED:
+ mpz_out_str (dumpfile, 10, p->value.integer);
+ fputc('u', dumpfile);
+
+ if (p->ts.kind != gfc_default_integer_kind)
+ fprintf (dumpfile, "_%d", p->ts.kind);
+ break;
+
case BT_LOGICAL:
if (p->value.logical)
fputs (".true.", dumpfile);
@@ -159,6 +159,7 @@ gfc_get_constant_expr (bt type, int kind, locus *where)
switch (type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
mpz_init (e->value.integer);
break;
@@ -296,6 +297,7 @@ gfc_copy_expr (gfc_expr *p)
switch (q->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
mpz_init_set (q->value.integer, p->value.integer);
break;
@@ -696,7 +698,6 @@ gfc_extract_int (gfc_expr *expr, int *result, int report_error)
return false;
}
-
/* Same as gfc_extract_int, but use a HWI. */
bool
@@ -899,7 +900,8 @@ gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
static bool
numeric_type (bt type)
{
- return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
+ return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER
+ || type == BT_UNSIGNED;
}
@@ -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. */
@@ -705,7 +706,12 @@ enum gfc_isym_id
GFC_ISYM_Y0,
GFC_ISYM_Y1,
GFC_ISYM_YN,
- GFC_ISYM_YN2
+ GFC_ISYM_YN2,
+
+ /* Add this at the end, so maybe the module format
+ remains compatible. */
+ GFC_ISYM_SU_KIND,
+ GFC_ISYM_UINT,
};
enum init_local_logical
@@ -2735,6 +2741,25 @@ gfc_integer_info;
extern gfc_integer_info gfc_integer_kinds[];
+/* Unsigned numbers, experimental. */
+
+typedef struct
+{
+ mpz_t huge, int_min;
+
+ int kind, radix, digits, bit_size, range;
+
+ /* True if the C type of the given name maps to this precision. Note that
+ more than one bit can be set. We will use this later on. */
+ unsigned int c_unsigned_char : 1;
+ unsigned int c_unsigned_short : 1;
+ unsigned int c_unsigned_int : 1;
+ unsigned int c_unsigned_long : 1;
+ unsigned int c_unsigned_long_long : 1;
+}
+gfc_unsigned_info;
+
+extern gfc_unsigned_info gfc_unsigned_kinds[];
typedef struct
{
@@ -3447,7 +3472,10 @@ 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);
+void gfc_reduce_unsigned (gfc_expr *e);
extern bool gfc_seen_div0;
@@ -3459,6 +3487,7 @@ tree gfc_get_union_type (gfc_symbol *);
tree gfc_get_derived_type (gfc_symbol * derived, int codimen = 0);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
+extern int gfc_default_unsigned_kind;
extern int gfc_max_integer_kind;
extern int gfc_default_real_kind;
extern int gfc_default_double_kind;
@@ -4001,10 +4030,12 @@ bool gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
size_t*, size_t*, size_t*);
bool gfc_boz2int (gfc_expr *, int);
+bool gfc_boz2uint (gfc_expr *, int);
bool gfc_boz2real (gfc_expr *, int);
bool gfc_invalid_boz (const char *, locus *);
bool gfc_invalid_null_arg (gfc_expr *);
+bool gfc_invalid_unsigned_ops (gfc_expr *, gfc_expr *);
/* class.cc */
void gfc_fix_class_refs (gfc_expr *e);
@@ -4087,6 +4118,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 sign = true);
/* trans-array.cc */
@@ -1192,6 +1192,7 @@ extensions.
@menu
* Extensions implemented in GNU Fortran::
* Extensions not implemented in GNU Fortran::
+* Experimental features for Fortran 202Y::
@end menu
@@ -2701,7 +2702,90 @@ descriptor occurred, use @code{INQUIRE} to get the file position,
count the characters up to the next @code{NEW_LINE} and then start
reading from the position marked previously.
+@node Experimental features for Fortran 202Y
+@section Experimental features for Fortran 202Y
+@cindex Fortran 202Y
+GNU Fortran supports some experimental features which have been
+proposed and accepted by the J3 standards committee. These
+exist to give users a chance to try them out, and to provide
+a reference implementation.
+
+As these features have not been finalized, there is a chance that the
+version in the upcoming standard will differ from what GNU Fortran
+currently implements. Stability of these implementations is therefore
+not guaranteed.
+
+@menu
+* Unsigned integers::
+@end menu
+
+@node Unsigned integers
+@subsection Unsigned integers
+@cindex Unsigned integers
+GNU Fortran supports unsigned integers according to
+@uref{https://j3-fortran.org/doc/year/24/24-116.txt, J3/24-116}. The
+data type is called @code{UNSIGNED}. For an unsigned type with $n$ bits,
+it implements integer arithmetic modulo @code{2**n}, comparable to the
+@code{unsigned} data type in C.
+
+The data type has @code{KIND} numbers comparable to other Fortran data
+types, which can be selected via the @code{SELECTED_UNSIGNED_KIND}
+function.
+
+Mixed arithmetic, comparisoins and assignment between @code{UNSIGNED}
+and other types are only possible via explicit conversion. Conversion
+from @code{UNSIGNED} to other types is done via type conversion
+functions like @code{INT} or @code{REAL}. Conversion from other types
+to @code{UNSIGNED} is done via @code{UINT}. Unsigned variables cannot be
+used as index variables in @code{DO} loops or as array indices.
+
+Unsigned numbers have a trailing @code{u} as suffix, optionally followed
+by a @code{KIND} number separated by an underscore.
+
+Input and output can be done using the @code{I}, @code{B}, @code{O}
+and @code{Z} descriptors, plus unformatted I/O.
+
+Here is a small, somewhat contrived example of their use:
+@smallexample
+program main
+ unsigned(kind=8) :: v
+ v = huge(v) - 32u_8
+ print *,v
+end program main
+@end smallexample
+which will output the number 18446744073709551583.
+
+Arithmetic operations work on unsigned integers, except for exponentiation,
+which is prohibited. Unary minus is not permitted when @code{-predantic}
+is in force; this prohibition is part of J3/24-116.txt.
+
+Generally, unsigned integers are only permitted as data in intrinsics.
+
+Unsigned numbers can be read and written using list-directed,
+formatted and unformatted I/O. For formatted I/O, the @code{B},
+@code{I}, @code{O} and @code{Z} descriptors are valid. Negative
+values and values which would overflow are rejected with
+@code{-pedantic}.
+
+As of now, the following intrinsics take unsigned arguments:
+@itemize @bullet
+@item @code{BLT}, @code{BLE}, @code{BGE} and @code{BGT}. These intrinsics
+ are actually redundant because comparison operators could be used
+ directly.
+@item @code{IAND}, @code{IOR}, @code{IEOR} and @code{NOT}
+@item @code{BIT_SIZE}, @code{DIGITS} and @code{HUGE}
+@item @code{DSHIFTL} and @code{DSHIFTR}
+@item @code{IBCLR}, @code{IBITS} and @code{IBITS}
+@item @code{MIN} and @code{MAX}
+@item @code{ISHFT}, @code{ISHFTC}, @code{SHIFTL}, @code{SHIFTR} and @code{SHIFTA}.
+@item @code{MERGE_BITS}
+@item @code{MOD} and @code{MODULO}
+@item @code{MVBITS}
+@item @code{RANGE}
+@item @code{TRANSFER}
+@end itemize
+This list will grow in the near future.
@c ---------------------------------------------------------------------
@c ---------------------------------------------------------------------
@c Mixed-Language Programming
@@ -95,6 +95,12 @@ gfc_type_letter (bt type, bool logical_equals_int)
c = 'h';
break;
+ /* 'u' would be the logical choice, but it is used for
+ "unknown", let's use m for "modulo". */
+ case BT_UNSIGNED:
+ c = 'm';
+ break;
+
default:
c = 'u';
break;
@@ -1655,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);
@@ -2256,6 +2262,12 @@ add_functions (void)
make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
+ add_sym_2 ("uint", GFC_ISYM_UINT, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNSIGNED, di, GFC_STD_GNU,
+ gfc_check_uint, gfc_simplify_uint, gfc_resolve_uint,
+ a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("uint", GFC_ISYM_UINT, GFC_STD_GNU);
+
add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_F95,
gfc_check_iand_ieor_ior, gfc_simplify_ior, gfc_resolve_ior,
@@ -2685,7 +2697,7 @@ add_functions (void)
make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
- gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
+ gfc_check_mod, gfc_simplify_mod, gfc_resolve_mod,
a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
if (flag_dec_intrinsic_ints)
@@ -2707,7 +2719,7 @@ add_functions (void)
make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95,
- gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
+ gfc_check_mod, gfc_simplify_modulo, gfc_resolve_modulo,
a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
@@ -2735,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)
@@ -2784,14 +2796,14 @@ add_functions (void)
add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_i, gfc_simplify_popcnt, NULL,
+ gfc_check_iu, gfc_simplify_popcnt, NULL,
i, BT_INTEGER, di, REQUIRED);
make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008);
add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_i, gfc_simplify_poppar, NULL,
+ gfc_check_iu, gfc_simplify_poppar, NULL,
i, BT_INTEGER, di, REQUIRED);
make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008);
@@ -2952,6 +2964,16 @@ add_functions (void)
make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
+ if (flag_unsigned)
+ {
+
+ add_sym_1 ("selected_unsigned_kind", GFC_ISYM_SU_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_GNU, gfc_check_selected_int_kind,
+ gfc_simplify_selected_unsigned_kind, NULL, r, BT_INTEGER, di, REQUIRED);
+
+ make_generic ("selected_unsigned_kind", GFC_ISYM_SU_KIND, GFC_STD_GNU);
+ }
+
add_sym_1 ("selected_logical_kind", GFC_ISYM_SL_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_F2023, /* it has the same requirements */ gfc_check_selected_int_kind,
gfc_simplify_selected_logical_kind, NULL, r, BT_INTEGER, di, REQUIRED);
@@ -4043,6 +4065,15 @@ add_conversions (void)
BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
}
+ if (flag_unsigned)
+ {
+ for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
+ for (j = 0; gfc_unsigned_kinds[j].kind != 0; j++)
+ if (i != j)
+ add_conv (BT_UNSIGNED, gfc_unsigned_kinds[i].kind,
+ BT_UNSIGNED, gfc_unsigned_kinds[j].kind, GFC_STD_GNU);
+ }
+
if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
{
/* Hollerith-Integer conversions. */
@@ -5316,7 +5347,8 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag,
else if (from_ts.type == ts->type
|| (from_ts.type == BT_INTEGER && ts->type == BT_REAL)
|| (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX)
- || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX))
+ || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)
+ || (from_ts.type == BT_UNSIGNED && ts->type == BT_UNSIGNED))
{
/* Larger kinds can hold values of smaller kinds without problems.
Hence, only warn if target kind is smaller than the source
@@ -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 *);
@@ -98,6 +99,7 @@ bool gfc_check_image_status (gfc_expr *, gfc_expr *);
bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_int (gfc_expr *, gfc_expr *);
bool gfc_check_intconv (gfc_expr *);
+bool gfc_check_uint (gfc_expr *, gfc_expr *);
bool gfc_check_irand (gfc_expr *);
bool gfc_check_is_contiguous (gfc_expr *);
bool gfc_check_isatty (gfc_expr *);
@@ -124,6 +126,7 @@ bool gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_minloc_maxloc (gfc_actual_arglist *);
bool gfc_check_minval_maxval (gfc_actual_arglist *);
+bool gfc_check_mod (gfc_expr *, gfc_expr *);
bool gfc_check_nearest (gfc_expr *, gfc_expr *);
bool gfc_check_new_line (gfc_expr *);
bool gfc_check_norm2 (gfc_expr *, gfc_expr *);
@@ -324,6 +327,7 @@ gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_uint (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int2 (gfc_expr *);
gfc_expr *gfc_simplify_int8 (gfc_expr *);
gfc_expr *gfc_simplify_long (gfc_expr *);
@@ -399,6 +403,7 @@ gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *);
+gfc_expr *gfc_simplify_selected_unsigned_kind (gfc_expr *);
gfc_expr *gfc_simplify_selected_logical_kind (gfc_expr *);
gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
@@ -530,6 +535,7 @@ void gfc_resolve_iall (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_iany (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_idnint (gfc_expr *, gfc_expr *);
void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_uint (gfc_expr *, gfc_expr*, gfc_expr *);
void gfc_resolve_int2 (gfc_expr *, gfc_expr *);
void gfc_resolve_int8 (gfc_expr *, gfc_expr *);
void gfc_resolve_long (gfc_expr *, gfc_expr *);
@@ -129,7 +129,7 @@ by type. Explanations are in the following sections.
-fmodule-private -ffixed-form -fno-range-check -fopenacc -fopenmp
-fopenmp-allocators -fopenmp-simd -freal-4-real-10 -freal-4-real-16
-freal-4-real-8 -freal-8-real-10 -freal-8-real-16 -freal-8-real-4
--std=@var{std} -ftest-forall-temp
+-std=@var{std} -ftest-forall-temp -funsigned
}
@item Preprocessing Options
@@ -611,6 +611,9 @@ earlier gfortran versions and should not be used any more.
@item -ftest-forall-temp
Enhance test coverage by forcing most forall assignments to use temporary.
+@opindex @code{funsigned}
+@item -funsigned
+Allow the experimental unsigned extension.
@end table
@node Preprocessing Options
@@ -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_m_%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_m_%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_m_%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_m_%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_m_%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_m_%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);
}
@@ -1345,6 +1356,18 @@ gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
gfc_type_abi_kind (&a->ts));
}
+void
+gfc_resolve_uint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
+{
+ f->ts.type = BT_UNSIGNED;
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__uint_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type),
+ gfc_type_abi_kind (&a->ts));
+}
+
void
gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
@@ -1977,7 +2000,10 @@ gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
gfc_expr *mask ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
- f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
+
+ f->value.function.name =
+ gfc_get_string ("__merge_bits_%c%d", gfc_type_letter (i->ts.type),
+ i->ts.kind);
}
@@ -2213,7 +2239,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);
}
@@ -788,6 +788,10 @@ frepack-arrays
Fortran Var(flag_repack_arrays)
Copy array sections into a contiguous block on procedure entry.
+funsigned
+Fortran Var(flag_unsigned)
+Experimental unsigned numbers.
+
fcoarray=
Fortran RejectNegative Joined Enum(gfc_fcoarray) Var(flag_coarray) Init(GFC_FCOARRAY_NONE)
-fcoarray=<none|single|lib> Specify which coarray parallelization should be used.
@@ -190,7 +190,7 @@ typedef enum
typedef enum
{ BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
- BT_ASSUMED, BT_UNION, BT_BOZ
+ BT_ASSUMED, BT_UNION, BT_BOZ, BT_UNSIGNED
}
bt;
@@ -2131,6 +2131,13 @@ gfc_match_type_spec (gfc_typespec *ts)
goto kind_selector;
}
+ if (flag_unsigned && gfc_match ("unsigned") == MATCH_YES)
+ {
+ ts->type = BT_UNSIGNED;
+ ts->kind = gfc_default_integer_kind;
+ goto kind_selector;
+ }
+
if (gfc_match ("double precision") == MATCH_YES)
{
ts->type = BT_REAL;
@@ -70,6 +70,9 @@ gfc_basic_typename (bt type)
case BT_INTEGER:
p = "INTEGER";
break;
+ case BT_UNSIGNED:
+ p = "UNSIGNED";
+ break;
case BT_REAL:
p = "REAL";
break;
@@ -145,6 +148,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
else
sprintf (buffer, "INTEGER(%d)", ts->kind);
break;
+ case BT_UNSIGNED:
+ sprintf (buffer, "UNSIGNED(%d)", ts->kind);
+ break;
case BT_REAL:
sprintf (buffer, "REAL(%d)", ts->kind);
break;
@@ -209,6 +209,44 @@ convert_integer (const char *buffer, int kind, int radix, locus *where)
}
+/* Convert an unsigned string to an expression node. XXX:
+ This needs a calculation modulo 2^n. TODO: Implement restriction
+ that no unary minus is permitted. */
+static gfc_expr *
+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. */
+ if (buffer[0] == '+')
+ t = buffer + 1;
+ else
+ t = buffer;
+
+ 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)
+ {
+ if (pedantic)
+ gfc_error_now (gfc_arith_error (rc), &e->where);
+ else
+ gfc_warning (0, gfc_arith_error (rc), &e->where);
+ }
+
+ gfc_convert_mpz_to_unsigned (e->value.integer, gfc_unsigned_kinds[k].bit_size,
+ false);
+
+ return e;
+}
+
/* Convert a real string to an expression node. */
static gfc_expr *
@@ -296,6 +334,71 @@ match_integer_constant (gfc_expr **result, int signflag)
return MATCH_YES;
}
+/* Match an unsigned constant (an integer with suffixed u). No sign
+ is currently accepted, in accordance with 24-116.txt, but that
+ could be changed later. This is very much like the integer
+ constant matching above, but with enough differences to put it into
+ its own function. */
+
+static match
+match_unsigned_constant (gfc_expr **result)
+{
+ int length, kind, is_iso_c;
+ locus old_loc;
+ char *buffer;
+ gfc_expr *e;
+ match m;
+
+ old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
+
+ length = match_digits (/* signflag = */ false, 10, NULL);
+
+ if (length == -1)
+ goto fail;
+
+ m = gfc_match_char ('u');
+ if (m == MATCH_NO)
+ goto fail;
+
+ gfc_current_locus = old_loc;
+
+ buffer = (char *) alloca (length + 1);
+ memset (buffer, '\0', length + 1);
+
+ gfc_gobble_whitespace ();
+
+ match_digits (false, 10, buffer);
+
+ m = gfc_match_char ('u');
+ if (m == MATCH_NO)
+ goto fail;
+
+ kind = get_kind (&is_iso_c);
+ if (kind == -2)
+ kind = gfc_default_unsigned_kind;
+ if (kind == -1)
+ return MATCH_ERROR;
+
+ if (kind == 4 && flag_integer4_kind == 8)
+ kind = 8;
+
+ if (gfc_validate_kind (BT_UNSIGNED, kind, true) < 0)
+ {
+ gfc_error ("Unsigned kind %d at %C not available", kind);
+ return MATCH_ERROR;
+ }
+
+ e = convert_unsigned (buffer, kind, 10, &gfc_current_locus);
+ e->ts.is_c_interop = is_iso_c;
+
+ *result = e;
+ return MATCH_YES;
+
+ fail:
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+}
/* Match a Hollerith constant. */
@@ -1549,6 +1652,13 @@ gfc_match_literal_constant (gfc_expr **result, int signflag)
if (m != MATCH_NO)
return m;
+ if (flag_unsigned)
+ {
+ m = match_unsigned_constant (result);
+ if (m != MATCH_NO)
+ return m;
+ }
+
m = match_integer_constant (result, signflag);
if (m != MATCH_NO)
return m;
@@ -4339,4 +4449,3 @@ gfc_match_equiv_variable (gfc_expr **result)
{
return match_variable (result, 1, 0);
}
-
@@ -4190,6 +4190,13 @@ resolve_operator (gfc_expr *e)
gfc_op2string (e->value.op.op));
return false;
}
+ if (flag_unsigned && pedantic && e->ts.type == BT_UNSIGNED
+ && e->value.op.op == INTRINSIC_UMINUS)
+ {
+ gfc_error ("Negation of unsigned expression at %L not permitted ",
+ &e->value.op.op1->where);
+ return false;
+ }
break;
}
@@ -4238,11 +4245,36 @@ resolve_operator (gfc_expr *e)
gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
return false;
+ case INTRINSIC_POWER:
+
+ if (flag_unsigned)
+ {
+ if (op1->ts.type == BT_UNSIGNED || op2->ts.type == BT_UNSIGNED)
+ {
+ CHECK_INTERFACES
+ gfc_error ("Exponentiation not valid at %L for %s and %s",
+ &e->where, gfc_typename (op1), gfc_typename (op2));
+ return false;
+ }
+ }
+ gcc_fallthrough();
+
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
- case INTRINSIC_POWER:
+
+ /* UNSIGNED cannot appear in a mixed expression without explicit
+ conversion. */
+ if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
+ {
+ CHECK_INTERFACES
+ gfc_error ("Operands of binary numeric operator %<%s%> at %L are %s/%s",
+ gfc_op2string (e->value.op.op), &e->where,
+ gfc_typename (op1), gfc_typename (op2));
+ return false;
+ }
+
if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
{
/* Do not perform conversions if operands are not conformable as
@@ -4445,6 +4477,15 @@ resolve_operator (gfc_expr *e)
return false;
}
+ if (flag_unsigned && gfc_invalid_unsigned_ops (op1, op2))
+ {
+ CHECK_INTERFACES
+ gfc_error ("Inconsistent types for operator at %L and %L: "
+ "%s and %s", &op1->where, &op2->where,
+ gfc_typename (op1), gfc_typename (op2));
+ return false;
+ }
+
gfc_type_convert_binary (e, 1);
e->ts.type = BT_LOGICAL;
@@ -11524,6 +11565,13 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
return false;
}
+ if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
+ {
+ gfc_error (_("Cannot assign %s to %s at %L"), gfc_typename (rhs),
+ gfc_typename (lhs), &rhs->where);
+ return false;
+ }
+
/* Handle the case of a BOZ literal on the RHS. */
if (rhs->ts.type == BT_BOZ)
{
@@ -147,8 +147,8 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
The conversion is a no-op unless x is negative; otherwise, it can
be accomplished by masking out the high bits. */
-static void
-convert_mpz_to_unsigned (mpz_t x, int bitsize)
+void
+gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool sign)
{
mpz_t mask;
@@ -156,7 +156,7 @@ convert_mpz_to_unsigned (mpz_t x, int bitsize)
{
/* 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 @@ convert_mpz_to_unsigned (mpz_t x, int bitsize)
{
/* Confirm that no bits above the signed range are set if we
are doing range checking. */
- if (flag_range_check != 0)
+ if (sign && flag_range_check != 0)
gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
}
}
@@ -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);
}
@@ -1693,11 +1699,11 @@ compare_bitwise (gfc_expr *i, gfc_expr *j)
mpz_init_set (x, i->value.integer);
k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
- convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+ gfc_convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
mpz_init_set (y, j->value.integer);
k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
- convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
+ gfc_convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
res = mpz_cmp (x, y);
mpz_clear (x);
@@ -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)
{
@@ -1798,6 +1831,7 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
switch (x->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
break;
@@ -1819,6 +1853,7 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
switch (y->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
mpfr_set_z (mpc_imagref (result->value.complex),
y->value.integer, GFC_RND_MODE);
break;
@@ -2354,6 +2389,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;
@@ -2454,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);
@@ -2468,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++)
@@ -2479,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;
}
@@ -3263,7 +3315,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;
@@ -3367,11 +3423,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");
@@ -3403,13 +3461,18 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
result->representation.string = NULL;
}
- 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;
}
@@ -3434,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);
+
+ if (x->ts.type == BT_INTEGER)
+ bitsize = gfc_integer_kinds[k].bit_size;
+ else
+ bitsize = gfc_unsigned_kinds[k].bit_size;
- bitsize = gfc_integer_kinds[k].bit_size;
if (pos + len > bitsize)
{
@@ -3446,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);
- 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);
@@ -3469,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;
}
@@ -3501,13 +3571,18 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
result->representation.string = NULL;
}
- 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;
}
@@ -3545,11 +3620,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");
@@ -3627,7 +3704,6 @@ done:
return range_check (result, "INDEX");
}
-
static gfc_expr *
simplify_intconv (gfc_expr *e, int kind, const char *name)
{
@@ -3738,16 +3814,48 @@ gfc_simplify_idint (gfc_expr *e)
return range_check (result, "IDINT");
}
+gfc_expr *
+gfc_simplify_uint (gfc_expr *e, gfc_expr *k)
+{
+ gfc_expr *result = NULL;
+ int kind;
+
+ kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+
+ /* Convert BOZ to integer, and return without range checking. */
+ if (e->ts.type == BT_BOZ)
+ {
+ if (!gfc_boz2uint (e, kind))
+ return NULL;
+ result = gfc_copy_expr (e);
+ return result;
+ }
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_convert_constant (e, BT_UNSIGNED, kind);
+
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ return range_check (result, "UINT");
+}
+
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");
@@ -3823,8 +3931,11 @@ simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
gfc_extract_int (s, &shift);
- k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
- bitsize = gfc_integer_kinds[k].bit_size;
+ k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ if (e->ts.type == BT_INTEGER)
+ bitsize = gfc_integer_kinds[k].bit_size;
+ else
+ bitsize = gfc_unsigned_kinds[k].bit_size;
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
@@ -3900,7 +4011,11 @@ simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
}
}
- gfc_convert_mpz_to_signed (result->value.integer, bitsize);
+ if (result->ts.type == BT_INTEGER)
+ gfc_convert_mpz_to_signed (result->value.integer, bitsize);
+ else
+ gfc_reduce_unsigned(result);
+
free (bits);
return result;
@@ -4000,7 +4115,8 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
if (shift == 0)
return result;
- convert_mpz_to_unsigned (result->value.integer, isize);
+ if (result->ts.type == BT_INTEGER)
+ gfc_convert_mpz_to_unsigned (result->value.integer, isize);
bits = XCNEWVEC (int, ssize);
@@ -4046,7 +4162,8 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
}
}
- gfc_convert_mpz_to_signed (result->value.integer, isize);
+ if (result->ts.type == BT_INTEGER)
+ gfc_convert_mpz_to_signed (result->value.integer, isize);
free (bits);
return result;
@@ -5104,7 +5221,7 @@ gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
|| mask_expr->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
+ result = gfc_get_constant_expr (i->ts.type, i->ts.kind, &i->where);
/* Convert all argument to unsigned. */
mpz_init_set (arg1, i->value.integer);
@@ -5135,6 +5252,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
switch (arg->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
if (extremum->ts.kind < arg->ts.kind)
extremum->ts.kind = arg->ts.kind;
ret = mpz_cmp (arg->value.integer,
@@ -6113,6 +6231,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
switch (p->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
gfc_error ("Argument %qs of MOD at %L shall not be zero",
@@ -6138,7 +6257,7 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
- if (a->ts.type == BT_INTEGER)
+ if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED)
mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
else
{
@@ -6165,6 +6284,7 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
switch (p->ts.type)
{
case BT_INTEGER:
+ case BT_UNSIGNED:
if (mpz_cmp_ui (p->value.integer, 0) == 0)
{
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
@@ -6190,8 +6310,8 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
- if (a->ts.type == BT_INTEGER)
- mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
+ if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED)
+ mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
else
{
gfc_set_model_kind (kind);
@@ -6646,11 +6766,16 @@ gfc_simplify_popcnt (gfc_expr *e)
k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- /* Convert argument to unsigned, then count the '1' bits. */
- mpz_init_set (x, e->value.integer);
- convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
- res = mpz_popcount (x);
- mpz_clear (x);
+ if (flag_unsigned && e->ts.type == BT_UNSIGNED)
+ res = mpz_popcount (e->value.integer);
+ else
+ {
+ /* Convert argument to unsigned, then count the '1' bits. */
+ mpz_init_set (x, e->value.integer);
+ gfc_convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+ res = mpz_popcount (x);
+ mpz_clear (x);
+ }
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
}
@@ -6727,6 +6852,10 @@ gfc_simplify_range (gfc_expr *e)
i = gfc_integer_kinds[i].range;
break;
+ case BT_UNSIGNED:
+ i = gfc_unsigned_kinds[i].range;
+ break;
+
case BT_REAL:
case BT_COMPLEX:
i = gfc_real_kinds[i].range;
@@ -7404,6 +7533,29 @@ gfc_simplify_selected_int_kind (gfc_expr *e)
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
}
+/* Same as above, but with unsigneds. */
+
+gfc_expr *
+gfc_simplify_selected_unsigned_kind (gfc_expr *e)
+{
+ int i, kind, range;
+
+ if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
+ return NULL;
+
+ kind = INT_MAX;
+
+ for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
+ if (gfc_unsigned_kinds[i].range >= range
+ && gfc_unsigned_kinds[i].kind < kind)
+ kind = gfc_unsigned_kinds[i].kind;
+
+ if (kind == INT_MAX)
+ kind = -1;
+
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
+}
+
gfc_expr *
gfc_simplify_selected_logical_kind (gfc_expr *e)
@@ -8793,6 +8945,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
case BT_INTEGER:
f = gfc_int2int;
break;
+ case BT_UNSIGNED:
+ f = gfc_int2uint;
+ break;
case BT_REAL:
f = gfc_int2real;
break;
@@ -8807,12 +8962,38 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
}
break;
+ case BT_UNSIGNED:
+ switch (type)
+ {
+ case BT_INTEGER:
+ f = gfc_uint2int;
+ break;
+ case BT_UNSIGNED:
+ f = gfc_uint2uint;
+ break;
+ case BT_REAL:
+ f = gfc_uint2real;
+ break;
+ case BT_COMPLEX:
+ f = gfc_uint2complex;
+ break;
+ case BT_LOGICAL:
+ f = gfc_uint2log;
+ break;
+ default:
+ goto oops;
+ }
+ break;
+
case BT_REAL:
switch (type)
{
case BT_INTEGER:
f = gfc_real2int;
break;
+ case BT_UNSIGNED:
+ f = gfc_real2uint;
+ break;
case BT_REAL:
f = gfc_real2real;
break;
@@ -8830,6 +9011,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
case BT_INTEGER:
f = gfc_complex2int;
break;
+ case BT_UNSIGNED:
+ f = gfc_complex2uint;
+ break;
case BT_REAL:
f = gfc_complex2real;
break;
@@ -8848,6 +9032,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
case BT_INTEGER:
f = gfc_log2int;
break;
+ case BT_UNSIGNED:
+ f = gfc_log2uint;
+ break;
case BT_LOGICAL:
f = gfc_log2log;
break;
@@ -8863,6 +9050,11 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
f = gfc_hollerith2int;
break;
+ /* Hollerith is for legacy code, we do not currently support
+ converting this to UNSIGNED. */
+ case BT_UNSIGNED:
+ goto oops;
+
case BT_REAL:
f = gfc_hollerith2real;
break;
@@ -8891,6 +9083,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
f = gfc_character2int;
break;
+ case BT_UNSIGNED:
+ goto oops;
+
case BT_REAL:
f = gfc_character2real;
break;
@@ -42,6 +42,11 @@ size_integer (int kind)
return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind)));
}
+static size_t
+size_unsigned (int kind)
+{
+ return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_unsigned_type (kind)));
+}
static size_t
size_float (int kind)
@@ -85,6 +90,9 @@ gfc_element_size (gfc_expr *e, size_t *siz)
case BT_INTEGER:
*siz = size_integer (e->ts.kind);
return true;
+ case BT_UNSIGNED:
+ *siz = size_unsigned (e->ts.kind);
+ return true;
case BT_REAL:
*siz = size_float (e->ts.kind);
return true;
@@ -206,6 +206,14 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind)
return wide_int_to_tree (gfc_get_int_type (kind), val);
}
+/* Same, but for unsigned. */
+
+tree
+gfc_conv_mpz_unsigned_to_tree (mpz_t i, int kind)
+{
+ wide_int val = wi:: from_mpz (gfc_get_unsigned_type (kind), i, true);
+ return wide_int_to_tree (gfc_get_unsigned_type (kind), val);
+}
/* Convert a GMP integer into a tree node of type given by the type
argument. */
@@ -315,6 +323,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
else
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
+ case BT_UNSIGNED:
+ return gfc_conv_mpz_unsigned_to_tree (expr->value.integer, expr->ts.kind);
+
case BT_REAL:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
@@ -7098,6 +7098,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
? CFI_type_cfunptr : CFI_type_cptr);
break;
+
+ case BT_UNSIGNED:
+ gfc_internal_error ("Unsigned not yet implemented");
+
case BT_ASSUMED:
case BT_CLASS:
case BT_PROCEDURE:
@@ -5837,6 +5837,10 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
}
else
gcc_unreachable ();
+
+ case BT_UNSIGNED:
+ gfc_internal_error ("Unsigned not yet implemented");
+
case BT_PROCEDURE:
case BT_HOLLERITH:
case BT_UNION:
@@ -3423,6 +3423,13 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
args[0], args[1]);
break;
+ case BT_UNSIGNED:
+ /* Even easier, we only need one. */
+ type = TREE_TYPE (args[0]);
+ se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
+ args[0], args[1]);
+ break;
+
case BT_REAL:
fmod = NULL_TREE;
/* Check if we have a builtin fmod. */
@@ -6772,6 +6779,7 @@ gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
{
tree args[2], type, num_bits, cond;
tree bigshift;
+ bool do_convert = false;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
@@ -6780,15 +6788,24 @@ gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
type = TREE_TYPE (args[0]);
if (!arithmetic)
- args[0] = fold_convert (unsigned_type_for (type), args[0]);
+ {
+ args[0] = fold_convert (unsigned_type_for (type), args[0]);
+ do_convert = true;
+ }
else
gcc_assert (right_shift);
+ if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
+ {
+ do_convert = true;
+ args[0] = fold_convert (signed_type_for (type), args[0]);
+ }
+
se->expr = fold_build2_loc (input_location,
right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
TREE_TYPE (args[0]), args[0], args[1]);
- if (!arithmetic)
+ if (do_convert)
se->expr = fold_convert (type, se->expr);
if (!arithmetic)
@@ -10908,6 +10925,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
case GFC_ISYM_INT2:
case GFC_ISYM_INT8:
case GFC_ISYM_LONG:
+ case GFC_ISYM_UINT:
gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
break;
@@ -117,6 +117,8 @@ enum iocall
IOCALL_WRITE_DONE,
IOCALL_X_INTEGER,
IOCALL_X_INTEGER_WRITE,
+ IOCALL_X_UNSIGNED,
+ IOCALL_X_UNSIGNED_WRITE,
IOCALL_X_LOGICAL,
IOCALL_X_LOGICAL_WRITE,
IOCALL_X_CHARACTER,
@@ -335,6 +337,14 @@ gfc_build_io_library_fndecls (void)
get_identifier (PREFIX("transfer_integer_write")), ". w R . ",
void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+ iocall[IOCALL_X_UNSIGNED] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_unsigned")), ". w W . ",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_UNSIGNED_WRITE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_unsigned_write")), ". w R . ",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_logical")), ". w W . ",
void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
@@ -2341,6 +2351,15 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
break;
+ case BT_UNSIGNED:
+ arg2 = build_int_cst (unsigned_type_node, kind);
+ if (last_dt == READ)
+ function = iocall[IOCALL_X_UNSIGNED];
+ else
+ function = iocall[IOCALL_X_UNSIGNED_WRITE];
+
+ break;
+
case BT_REAL:
arg2 = build_int_cst (integer_type_node, kind);
if (last_dt == READ)
@@ -86,8 +86,10 @@ static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
#define MAX_INT_KINDS 5
gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
+gfc_unsigned_info gfc_unsigned_kinds[MAX_INT_KINDS + 1];
static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
+static GTY(()) tree gfc_unsigned_types[MAX_INT_KINDS + 1];
#define MAX_REAL_KINDS 5
gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
@@ -109,6 +111,7 @@ int gfc_index_integer_kind;
/* The default kinds of the various types. */
int gfc_default_integer_kind;
+int gfc_default_unsigned_kind;
int gfc_max_integer_kind;
int gfc_default_real_kind;
int gfc_default_double_kind;
@@ -413,6 +416,14 @@ gfc_init_kinds (void)
gfc_integer_kinds[i_index].digits = bitsize - 1;
gfc_integer_kinds[i_index].bit_size = bitsize;
+ if (flag_unsigned)
+ {
+ gfc_unsigned_kinds[i_index].kind = kind;
+ gfc_unsigned_kinds[i_index].radix = 2;
+ gfc_unsigned_kinds[i_index].digits = bitsize;
+ gfc_unsigned_kinds[i_index].bit_size = bitsize;
+ }
+
gfc_logical_kinds[i_index].kind = kind;
gfc_logical_kinds[i_index].bit_size = bitsize;
@@ -585,6 +596,8 @@ gfc_init_kinds (void)
gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
}
+ gfc_default_unsigned_kind = gfc_default_integer_kind;
+
/* Choose the default real kind. Again, we choose 4 when possible. */
if (flag_default_real_8)
{
@@ -756,6 +769,18 @@ validate_integer (int kind)
return -1;
}
+static int
+validate_unsigned (int kind)
+{
+ int i;
+
+ for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
+ if (gfc_unsigned_kinds[i].kind == kind)
+ return i;
+
+ return -1;
+}
+
static int
validate_real (int kind)
{
@@ -810,6 +835,9 @@ gfc_validate_kind (bt type, int kind, bool may_fail)
case BT_INTEGER:
rc = validate_integer (kind);
break;
+ case BT_UNSIGNED:
+ rc = validate_unsigned (kind);
+ break;
case BT_LOGICAL:
rc = validate_logical (kind);
break;
@@ -880,6 +908,24 @@ gfc_build_uint_type (int size)
return make_unsigned_type (size);
}
+static tree
+gfc_build_unsigned_type (gfc_unsigned_info *info)
+{
+ int mode_precision = info->bit_size;
+
+ if (mode_precision == CHAR_TYPE_SIZE)
+ info->c_unsigned_char = 1;
+ if (mode_precision == SHORT_TYPE_SIZE)
+ info->c_unsigned_short = 1;
+ if (mode_precision == INT_TYPE_SIZE)
+ info->c_unsigned_int = 1;
+ if (mode_precision == LONG_TYPE_SIZE)
+ info->c_unsigned_long = 1;
+ if (mode_precision == LONG_LONG_TYPE_SIZE)
+ info->c_unsigned_long_long = 1;
+
+ return gfc_build_uint_type (mode_precision);
+}
static tree
gfc_build_real_type (gfc_real_info *info)
@@ -1034,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);
@@ -1092,6 +1172,13 @@ gfc_get_int_type (int kind)
return index < 0 ? 0 : gfc_integer_types[index];
}
+tree
+gfc_get_unsigned_type (int kind)
+{
+ int index = gfc_validate_kind (BT_UNSIGNED, kind, true);
+ return index < 0 ? 0 : gfc_unsigned_types[index];
+}
+
tree
gfc_get_real_type (int kind)
{
@@ -1192,6 +1279,10 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim)
basetype = gfc_get_int_type (spec->kind);
break;
+ case BT_UNSIGNED:
+ basetype = gfc_get_unsigned_type (spec->kind);
+ break;
+
case BT_REAL:
basetype = gfc_get_real_type (spec->kind);
break;
@@ -76,6 +76,7 @@ void gfc_init_c_interop_kinds (void);
tree get_dtype_type_node (void);
tree gfc_get_int_type (int);
+tree gfc_get_unsigned_type (int);
tree gfc_get_real_type (int);
tree gfc_get_complex_type (int);
tree gfc_get_logical_type (int);
new file mode 100644
@@ -0,0 +1,16 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test some arithmetic and selected_unsigned_kind.
+program memain
+ unsigned :: u, v
+ integer, parameter :: u1 = selected_unsigned_kind(2), &
+ u2 = selected_unsigned_kind(4), &
+ u4 = selected_unsigned_kind(6), &
+ u8 = selected_unsigned_kind(10)
+ u = 1u
+ v = 42u
+ if (u + v /= 43u) then
+ error stop 1
+ end if
+ if (u1 /= 1 .or. u2 /= 2 .or. u4 /= 4 .or. u8 /= 8) error stop 2
+end program memain
new file mode 100644
@@ -0,0 +1,56 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test I/O with Z, O and B descriptors.
+
+program main
+ implicit none
+ unsigned(kind=8) :: u,v
+ integer :: i
+ open(10,status="scratch")
+ u = 3u
+ do i=0,63
+ write (10,'(Z16)') u
+ u = u + u
+ end do
+ rewind 10
+ u = 3u
+ do i=0,63
+ read (10,'(Z16)') v
+ if (u /= v) then
+ print *,u,v
+ end if
+ u = u + u
+ end do
+ rewind 10
+ u = 3u
+ do i=0,63
+ write (10,'(O22)') u
+ u = u + u
+ end do
+ rewind 10
+ u = 3u
+ do i=0,63
+ read (10,'(O22)') v
+ if (u /= v) then
+ print *,u,v
+ end if
+ u = u + u
+ end do
+
+ rewind 10
+ u = 3u
+ do i=0,63
+ write (10,'(B64)') u
+ u = u + u
+ end do
+ rewind 10
+ u = 3u
+ do i=0,63
+ read (10,'(B64)') v
+ if (u /= v) then
+ print *,u,v
+ end if
+ u = u + u
+ end do
+
+end program main
new file mode 100644
@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test min/max
+program main
+ unsigned :: u_a, u_b
+ if (max(1u,2u) /= 2u) error stop 1
+ if (max(2u,1u) /= 2u) error stop 2
+ if (min(1u,2u) /= 1u) error stop 3
+ if (min(2u,1u) /= 1u) error stop 4
+ u_a = 1u
+ u_b = 2u
+ if (max(u_a,u_b) /= u_b) error stop 5
+ if (max(u_b,u_a) /= u_b) error stop 6
+ if (min(u_a,u_b) /= u_a) error stop 7
+ if (min(u_b,u_a) /= u_a) error stop 8
+ if (max(4294967295u, 1u) /= 4294967295u) error stop 9
+ u_a = 4294967295u
+ u_b = 1u
+ if (max(u_a,u_b) /= 4294967295u) error stop 10
+ if (max(u_b,u_a) /= 4294967295u) error stop 11
+ if (min(u_a,u_b) /= 1u) error stop 12
+ if (min(u_b,u_a) /= 1u) error stop 13
+end program
new file mode 100644
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test some
+program main
+ unsigned :: u_a
+ u_a = 1u
+ if (ishft(1u,31) /= 2147483648u) error stop 1
+ if (ishft(u_a,31) /= 2147483648u) error stop 2
+
+ u_a = 3u
+ if (ishft(3u,2) /= 12u) error stop 3
+ if (ishft(u_a,2) /= 12u) error stop 4
+
+ u_a = huge(u_a)
+ if (ishftc(huge(u_a),1) /= huge(u_a)) error stop 5
+ if (ishftc(u_a,1) /= u_a) error stop 6
+
+end program
new file mode 100644
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test basic functionality of ishft and ishftc.
+program main
+ unsigned :: u_a
+ u_a = 1u
+ if (ishft(1u,31) /= 2147483648u) error stop 1
+ if (ishft(u_a,31) /= 2147483648u) error stop 2
+
+ u_a = 3u
+ if (ishft(3u,2) /= 12u) error stop 3
+ if (ishft(u_a,2) /= 12u) error stop 4
+
+ u_a = huge(u_a)
+ if (ishftc(huge(u_a),1) /= huge(u_a)) error stop 5
+ if (ishftc(u_a,1) /= u_a) error stop 6
+
+end program
new file mode 100644
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test basic functionality of merge_bits.
+program main
+ unsigned(kind=4) :: a, b, c
+ if (merge_bits(15u,51u,85u) /= 39u) error stop 1
+ a = 15u
+ b = 51u
+ c = 85u
+ if (merge_bits(a,b,c) /= 39u) error stop 2
+
+ if (merge_bits(4026531840u,3422552064u,2852126720u) /= 3825205248u) error stop 3
+
+ a = 4026531840u_4
+ b = 3422552064u_4
+ c = 2852126720u_4
+ if (merge_bits(a,b,c) /= 3825205248u) error stop 4
+end program
new file mode 100644
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! { dg-options "-funsigned" }
+! Test different prohibited conversions.
+program main
+ integer :: i
+ unsigned :: u
+ print *,1 + 2u ! { dg-error "Operands of binary numeric operator" }
+ print *,2u + 1 ! { dg-error "Operands of binary numeric operator" }
+ print *,2u ** 1 ! { dg-error "Exponentiation not valid" }
+ print *,2u ** 1u ! { dg-error "Exponentiation not valid" }
+ print *,1u < 2 ! { dg-error "Inconsistent types" }
+ print *,int(1u) < 2
+end program main
new file mode 100644
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-funsigned -pedantic" }
+! Some checks with -pedantic.
+program main
+ unsigned :: u
+ print *,-129u_1 ! { dg-error "Negation of unsigned constant" }
+ print *,256u_1 ! { dg-error "Unsigned constant truncated" }
+ u = 1u
+ u = -u ! { dg-error "Negation of unsigned expression" }
+end program
new file mode 100644
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test modulo and mod intrinsics.
+program main
+ unsigned :: u1, u2
+ if (mod(5u,2u) /= 1u) error stop 1
+ if (modulo(5u,2u) /= 1u) error stop 2
+ u1 = 5u
+ u2 = 2u
+ if (mod(u1,u2) /= 1u) error stop 3
+ if (modulo(u1,u2) /= 1u) error stop 4
+
+ if (mod(4294967295u,4294967281u) /= 14u) error stop 5
+ if (mod(4294967281u,4294967295u) /= 4294967281u) error stop 6
+ if (modulo(4294967295u,4294967281u) /= 14u) error stop 7
+ if (modulo(4294967281u,4294967295u) /= 4294967281u) error stop 8
+ u1 = 4294967295u
+ u2 = 4294967281u
+ if (mod(u1,u2) /= 14u) error stop 9
+ if (mod(u2,u1) /= u2) error stop 10
+end program main
new file mode 100644
@@ -0,0 +1,40 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+program memain
+ implicit none
+ unsigned(1) i1,j1
+ unsigned(2) i2,j2
+ unsigned(4) i4,j4
+ unsigned(8) i8,j8
+ integer ibits,n
+
+ ibits=bit_size(1u_1)
+ do n=1,ibits
+ i1=huge(i1)
+ call mvbits(1u_1, 0,n,i1,0)
+ j1=uint(-1-2_1**n+2)
+ if(i1.ne.j1) error stop 1
+ enddo
+ ibits=bit_size(1u_2)
+ do n=1,ibits
+ i2=huge(i2)
+ call mvbits(1u_2, 0,n,i2,0)
+ j2=uint(-1-2_2**n+2)
+ if(i2.ne.j2) error stop 2
+ enddo
+ ibits=bit_size(1u_4)
+ do n=1,ibits
+ i4=huge(i4)
+ call mvbits(1u_4, 0,n,i4,0)
+ j4=uint(-1-2_4**n+2)
+ if(i4.ne.j4) error stop 3
+ enddo
+ ibits=bit_size(1_8)
+ do n=1,ibits
+ i8=huge(i8)
+ call mvbits(1u_8, 0,n,i8,0)
+ j8=uint(-1-2_8**n+2,8)
+ if(i8.ne.j8) error stop 4
+ enddo
+
+end program memain
new file mode 100644
@@ -0,0 +1,8 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+program memain
+ if (range(1u_1) /= 2) error stop 1
+ if (range(1u_2) /= 4) error stop 2
+ if (range(1u_4) /= 9) error stop 3
+ if (range(1u_8) /= 19) error stop 4
+end program memain
new file mode 100644
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test some list-directed I/O
+program main
+ implicit none
+ unsigned :: uw, ur, vr
+ unsigned(kind=8) :: u8
+ uw = 10u
+ open (10, status="scratch")
+ write (10,*) uw,-1
+ rewind 10
+ read (10,*) ur,vr
+ if (ur /= 10u .or. vr /= 4294967295u) error stop 1
+ rewind 10
+ write (10,*) 17179869184u_8
+ rewind 10
+ read (10,*) u8
+ if (u8 /= 17179869184u_8) error stop 2
+end program main
+
new file mode 100644
@@ -0,0 +1,46 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+program memain
+
+ unsigned(1) :: u1
+ unsigned(2) :: u2
+ unsigned(4) :: u4
+ unsigned(8) :: u8
+
+ u1 = 1u_1
+ if (shifta ( 1u , 1) /= 0u_1) error stop 1
+ if (shifta ( u1 , 1) /= 0u_1) error stop 2
+
+ u1 = 128u_1
+ if (shifta ( 128u_1, 1) /= 192u_1) error stop 3
+ if (shiftl ( 128u_1, 1) /= 0u_1) error stop 4
+ if (shiftr ( 128u_1, 1) /= 64u_1) error stop 5
+
+ if (shifta ( u1, 1) /= 192u_1) error stop 6
+ if (shiftl ( u1, 1) /= 0u_1) error stop 7
+ if (shiftr ( u1, 1) /= 64u_1) error stop 8
+
+ u2 = 32768u_2
+ if (shifta ( 32768u_2, 1) /= 49152u_2) error stop 9
+ if (shiftl ( 32768u_2, 1) /= 0u_2) error stop 10
+ if (shiftr ( 32768u_2, 1) /= 16384u_2) error stop 11
+ if (shifta ( u2, 1) /= 49152u_2) error stop 12
+ if (shiftl ( u2, 1) /= 0u_2) error stop 13
+ if (shiftr ( u2, 1) /= 16384u_2) error stop 14
+
+ u4 = 2147483648u_4
+ if (shifta ( 2147483648u_4, 1) /= 3221225472u_4) error stop 15
+ if (shiftl ( 2147483648u_4, 1) /= 0u_4) error stop 16
+ if (shiftr ( 2147483648u_4, 1) /= 1073741824u_4) error stop 17
+ if (shifta ( u4, 1) /= 3221225472u_4) error stop 18
+ if (shiftl ( u4, 1) /= 0u_4) error stop 19
+ if (shiftr ( u4, 1) /= 1073741824u_4) error stop 20
+
+ u8 = 9223372036854775808u_8
+ if (shifta(9223372036854775808u_8, 1) /= 13835058055282163712u_8) error stop 21
+ if (shiftl(9223372036854775808u_8, 1) /= 0u_8) error stop 22
+ if (shiftr(9223372036854775808u_8, 1) /= 4611686018427387904u_8) error stop 23
+ if (shifta( u8, 1) /= 13835058055282163712u_8) error stop 24
+ if (shiftl( u8, 1) /= 0u_8) error stop 25
+ if (shiftr( u8, 1) /= 4611686018427387904u_8) error stop 26
+end program memain
new file mode 100644
@@ -0,0 +1,13 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+program main
+ integer :: i
+ integer(2) :: j
+ unsigned :: u
+ i = -1
+ u = transfer(i,u)
+ if (u /= huge(u)) error stop 1
+ u = 40000u
+ j = transfer(u,j)
+ if (j /= -25536) error stop 2
+end program main
new file mode 100644
@@ -0,0 +1,25 @@
+! { dg-do run }
+! { dg-options "-funsigned -pedantic" }
+program memain
+ implicit none
+ integer :: iostat
+ character(len=100) :: iomsg
+ unsigned :: u
+ open (10)
+ write (10,'(I10)') -1
+ write (10,'(I10)') 2_8**32
+ rewind 10
+ read (10,'(I10)',iostat=iostat,iomsg=iomsg) u
+ if (iostat == 0) error stop 1
+ if (iomsg /= "Negative sign for unsigned integer read") error stop 2
+ read (10,'(I10)',iostat=iostat,iomsg=iomsg) u
+ if (iostat == 0) error stop 3
+ if (iomsg /= "Value overflowed during unsigned integer read") error stop 4
+ rewind 10
+ read (10,*,iostat=iostat,iomsg=iomsg) u
+ if (iostat == 0) error stop 5
+ if (iomsg /= "Negative sign for unsigned integer in item 1 of list input ") error stop 6
+ read (10,*,iostat=iostat,iomsg=iomsg) u
+ if (iostat == 0) error stop 7
+ if (iomsg /= "Unsigned integer overflow while reading item 1 of list input") error stop 8
+ end program memain
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test some basic formatted I/O.
+
+program main
+ unsigned :: u
+ open (10,status="scratch")
+ write (10,'(I4)') 1u
+ write (10,'(I4)') -1
+ rewind 10
+ read (10,'(I4)') u
+ if (u /= 1u) error stop 1
+ read (10,'(I4)') u
+ if (u /= 4294967295u) error stop 2
+end program main
new file mode 100644
@@ -0,0 +1,123 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test conversions from unsigned to different data types by
+! doing some I/O.
+program main
+ implicit none
+ integer :: vi,i
+ integer, parameter :: n_int = 16, n_real = 8
+ unsigned(kind=1) :: u1
+ unsigned(kind=2) :: u2
+ unsigned(kind=4) :: u4
+ unsigned(kind=8) :: u8
+ unsigned :: u
+ integer, dimension(n_int) :: ires
+ real(kind=8), dimension(n_real) :: rres
+ real(kind=8) :: vr
+ complex (kind=8) :: vc
+ data ires /11,12,14,18,21,22,24,28,41,42,44,48,81,82,84,88/
+ data rres /14., 18., 24., 28., 44., 48., 84., 88./
+ open (10,status="scratch")
+
+ write (10,*) int(11u_1,1)
+ write (10,*) int(12u_1,2)
+ write (10,*) int(14u_1,4)
+ write (10,*) int(18u_1,8)
+
+ write (10,*) int(21u_2,1)
+ write (10,*) int(22u_2,2)
+ write (10,*) int(24u_2,4)
+ write (10,*) int(28u_2,8)
+
+ write (10,*) int(41u_4,1)
+ write (10,*) int(42u_4,2)
+ write (10,*) int(44u_4,4)
+ write (10,*) int(48u_4,8)
+
+ write (10,*) int(81u_8,1)
+ write (10,*) int(82u_8,2)
+ write (10,*) int(84u_8,4)
+ write (10,*) int(88u_8,8)
+
+ rewind 10
+ do i=1,n_int
+ read (10,*) vi
+ if (vi /= ires(i)) error stop 1
+ end do
+
+ rewind 10
+ u1 = 11u; write (10,*) int(u1,1)
+ u1 = 12u; write (10,*) int(u1,2)
+ u1 = 14u; write (10,*) int(u1,4)
+ u1 = 18u; write (10,*) int(u1,8)
+
+ u2 = 21u; write (10,*) int(u2,1)
+ u2 = 22u; write (10,*) int(u2,2)
+ u2 = 24u; write (10,*) int(u2,4)
+ u2 = 28u; write (10,*) int(u2,8)
+
+ u4 = 41u; write (10,*) int(u4,1)
+ u4 = 42u; write (10,*) int(u4,2)
+ u4 = 44u; write (10,*) int(u4,4)
+ u4 = 48u; write (10,*) int(u4,8)
+
+ u8 = 81u; write (10,*) int(u8,1)
+ u8 = 82u; write (10,*) int(u8,2)
+ u8 = 84u; write (10,*) int(u8,4)
+ u8 = 88u; write (10,*) int(u8,8)
+
+ rewind 10
+ do i=1,n_int
+ read (10,*) vi
+ if (vi /= ires(i)) error stop 2
+ end do
+
+ rewind 10
+ write (10,*) real(14u_1,4)
+ write (10,*) real(18u_1,8)
+ write (10,*) real(24u_2,4)
+ write (10,*) real(28u_2,8)
+ write (10,*) real(44u_4,4)
+ write (10,*) real(48u_4,8)
+ write (10,*) real(84u_8,4)
+ write (10,*) real(88u_8,8)
+
+ rewind 10
+ do i=1, n_real
+ read (10, *) vr
+ if (vr /= rres(i)) error stop 3
+ end do
+
+ rewind 10
+ u1 = 14u_1; write (10,*) real(u1,4)
+ u1 = 18u_1; write (10,*) real(u1,8)
+ u2 = 24u_2; write (10,*) real(u2,4)
+ u2 = 28u_2; write (10,*) real(u2,8)
+ u4 = 44u_4; write (10,*) real(u4,4)
+ u4 = 48u_4; write (10,*) real(u4,8)
+ u8 = 84u_4; write (10,*) real(u8,4)
+ u8 = 88u_4; write (10,*) real(u8,8)
+
+ rewind 10
+ do i=1, n_real
+ read (10, *) vr
+ if (vr /= rres(i)) error stop 4
+ end do
+
+ rewind 10
+ u1 = 14u_1; write (10,*) cmplx(14u_1,u1,kind=4)
+ u1 = 18u_1; write (10,*) cmplx(18u_1,u1,kind=8)
+ u2 = 24u_2; write (10,*) cmplx(24u_2,u2,kind=4)
+ u2 = 28u_2; write (10,*) cmplx(28u_2,u2,kind=8)
+ u4 = 44u_4; write (10,*) cmplx(44u_4,u4,kind=4)
+ u4 = 48u_8; write (10,*) cmplx(48u_4,u4,kind=8)
+ u8 = 84u_8; write (10,*) cmplx(84u_8,u8,kind=4)
+ u8 = 88u_8; write (10,*) cmplx(88u_8,u8,kind=8)
+
+ rewind 10
+ do i=1,n_real
+ read (10, *) vc
+ if (real(vc) /= rres(i)) error stop 5
+ if (aimag(vc) /= rres(i)) error stop 6
+ end do
+end program main
new file mode 100644
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test the uint intrinsic.
+program main
+ implicit none
+ integer :: i
+ real :: r
+ complex :: c
+ if (1u /= uint(1)) error stop 1
+ if (2u /= uint(2.0)) error stop 2
+ if (3u /= uint((3.2,0.))) error stop 3
+
+ i = 4
+ if (uint(i) /= 4u) error stop 4
+ r = 5.2
+ if (uint(r) /= 5u) error stop 5
+ c = (6.2,-1.2)
+ if (uint(c) /= 6u) error stop 6
+
+ if (uint(z'ff') /= 255u) error stop 7
+end program main
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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))) error stop 11
+ if (ibset(255,10) /= int(ibset(255u,10))) error stop 12
+
+ if (uint(ibits(6,6,2)) /= ibits(6u,6,2)) error stop 13
+end program main
@@ -1775,4 +1775,6 @@ GFORTRAN_15 {
global:
_gfortran_internal_pack_class;
_gfortran_internal_unpack_class;
+ _gfortran_transfer_unsigned;
+ _gfortran_transfer_unsigned_write;
} GFORTRAN_14;
@@ -861,9 +861,15 @@ internal_proto (transfer_array_inner);
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
internal_proto(set_integer);
+extern void set_unsigned (void *, GFC_UINTEGER_LARGEST, int);
+internal_proto(set_unsigned);
+
extern GFC_UINTEGER_LARGEST si_max (int);
internal_proto(si_max);
+extern GFC_UINTEGER_LARGEST us_max (int);
+internal_proto(us_max);
+
extern int convert_real (st_parameter_dt *, void *, const char *, int);
internal_proto(convert_real);
@@ -891,6 +897,10 @@ internal_proto(read_radix);
extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal);
+extern void read_decimal_unsigned (st_parameter_dt *, const fnode *, char *,
+ int);
+internal_proto(read_decimal_unsigned);
+
extern void read_user_defined (st_parameter_dt *, void *);
internal_proto(read_user_defined);
@@ -941,6 +951,9 @@ internal_proto(write_f);
extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_i);
+extern void write_iu (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_iu);
+
extern void write_l (st_parameter_dt *, const fnode *, char *, int);
internal_proto(write_l);
@@ -722,6 +722,86 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
return 1;
}
+/* Same as above, but for unsigneds, where overflow checks are only
+ preformed with -pedantic, except on the repeat count. */
+
+static int
+convert_unsigned (st_parameter_dt *dtp, int length, int negative)
+{
+ char c, *buffer, message[IOMSG_LEN];
+ GFC_UINTEGER_LARGEST v, value, max, v_old;
+ int m;
+
+ if (compile_options.pedantic && negative)
+ goto overflow;
+
+ buffer = dtp->u.p.saved_string;
+ max = length == -1 ? MAX_REPEAT : us_max(length);
+
+ v = 0;
+ for (;;)
+ {
+ c = *buffer++;
+ if (c == '\0')
+ break;
+ c -= '0';
+ v_old = v;
+ v = v * 10 + c;
+
+ if (length == -1 && v > max)
+ goto overflow;
+ else if (compile_options.pedantic && v < v_old)
+ goto overflow;
+ }
+
+ m = 0;
+
+ if (length != -1)
+ {
+ if (negative)
+ value = -v;
+ else
+ value = v;
+
+ if (compile_options.pedantic && value > max)
+ goto overflow;
+ else
+ value = value & max;
+
+ set_unsigned (dtp->u.p.value, value, length);
+ }
+ else
+ {
+ dtp->u.p.repeat_count = v;
+
+ if (dtp->u.p.repeat_count == 0)
+ {
+ snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input",
+ dtp->u.p.item_count);
+
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+ m = 1;
+ }
+ }
+ free_saved (dtp);
+ return m;
+
+ overflow:
+ if (length== -1)
+ snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input",
+ dtp->u.p.item_count);
+ else if (negative)
+ snprintf (message, IOMSG_LEN, "Negative sign for unsigned integer "
+ "in item %d of list input", dtp->u.p.item_count);
+ else
+ snprintf (message, IOMSG_LEN, "Unsigned integer overflow while reading "
+ "item %d of list input", dtp->u.p.item_count);
+
+ free_saved (dtp);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+
+ return 1;
+}
/* Parse a repeat count for logical and complex values which cannot
begin with a digit. Returns nonzero if we are done, zero if we
@@ -990,11 +1070,10 @@ read_logical (st_parameter_dt *dtp, int length)
used for repeat counts. */
static void
-read_integer (st_parameter_dt *dtp, int length)
+read_integer (st_parameter_dt *dtp, int length, bt type)
{
char message[IOMSG_LEN];
int c, negative;
-
negative = 0;
c = next_char (dtp);
@@ -1055,8 +1134,11 @@ read_integer (st_parameter_dt *dtp, int length)
}
repeat:
- if (convert_integer (dtp, -1, 0))
- return;
+ if (type == BT_INTEGER)
+ {
+ if (convert_integer (dtp, -1, 0))
+ return;
+ }
/* Get the real integer. */
@@ -1077,6 +1159,9 @@ read_integer (st_parameter_dt *dtp, int length)
return;
case '-':
+ if (compile_options.pedantic && type == BT_UNSIGNED)
+ goto bad_integer;
+
negative = 1;
/* Fall through... */
@@ -1127,8 +1212,13 @@ read_integer (st_parameter_dt *dtp, int length)
else if (c != '\n')
eat_line (dtp);
- snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input",
+ if (type == BT_INTEGER)
+ snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input",
dtp->u.p.item_count);
+ else
+ snprintf (message, IOMSG_LEN, "Bad unsigned for item %d in list input",
+ dtp->u.p.item_count);
+
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -1139,17 +1229,27 @@ read_integer (st_parameter_dt *dtp, int length)
eat_separator (dtp);
push_char (dtp, '\0');
- if (convert_integer (dtp, length, negative))
+ if (type == BT_INTEGER)
+ {
+ if (convert_integer (dtp, length, negative)) /* XXX */
+ {
+ free_saved (dtp);
+ return;
+ }
+ }
+ else
{
- free_saved (dtp);
- return;
+ if (convert_unsigned (dtp, length, negative)) /* XXX */
+ {
+ free_saved (dtp);
+ return;
+ }
}
free_saved (dtp);
- dtp->u.p.saved_type = BT_INTEGER;
+ dtp->u.p.saved_type = type;
}
-
/* Read a character variable. */
static void
@@ -2224,7 +2324,8 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
switch (type)
{
case BT_INTEGER:
- read_integer (dtp, kind);
+ case BT_UNSIGNED:
+ read_integer (dtp, kind, type);
break;
case BT_LOGICAL:
read_logical (dtp, kind);
@@ -2318,6 +2419,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
break;
case BT_INTEGER:
+ case BT_UNSIGNED:
case BT_LOGICAL:
memcpy (p, dtp->u.p.value, size);
break;
@@ -3029,7 +3131,8 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
switch (nl->type)
{
case BT_INTEGER:
- read_integer (dtp, len);
+ case BT_UNSIGNED:
+ read_integer (dtp, len, nl->type);
break;
case BT_LOGICAL:
@@ -92,6 +92,62 @@ set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
}
}
+/* set_integer()-- All of the integer assignments come here to
+ actually place the value into memory. */
+
+void
+set_unsigned (void *dest, GFC_UINTEGER_LARGEST value, int length)
+{
+ NOTE ("set_integer: %lld %p", (long long int) value, dest);
+ switch (length)
+ {
+#ifdef HAVE_GFC_UINTEGER_16
+#ifdef HAVE_GFC_REAL_17
+ case 17:
+ {
+ GFC_UINTEGER_16 tmp = value;
+ memcpy (dest, (void *) &tmp, 16);
+ }
+ break;
+#endif
+/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
+ case 10:
+ case 16:
+ {
+ GFC_UINTEGER_16 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+#endif
+ case 8:
+ {
+ GFC_UINTEGER_8 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ case 4:
+ {
+ GFC_UINTEGER_4 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ case 2:
+ {
+ GFC_UINTEGER_2 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ case 1:
+ {
+ GFC_UINTEGER_1 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ default:
+ internal_error (NULL, "Bad integer kind");
+ }
+}
+
/* Max signed value of size give by length argument. */
@@ -132,6 +188,28 @@ si_max (int length)
}
}
+GFC_UINTEGER_LARGEST
+us_max (int length)
+{
+ switch (length)
+ {
+#ifdef HAVE_GFC_UINTEGER_16
+ case 17:
+ case 16:
+ return GFC_UINTEGER_16_HUGE;
+#endif
+ case 8:
+ return GFC_UINTEGER_8_HUGE;
+ case 4:
+ return GFC_UINTEGER_4_HUGE;
+ case 2:
+ return GFC_UINTEGER_2_HUGE;
+ case 1:
+ return GFC_UINTEGER_1_HUGE;
+ default:
+ internal_error (NULL, "Bad unsigned kind");
+ }
+}
/* convert_real()-- Convert a character representation of a floating
point number to the machine number. Returns nonzero if there is an
@@ -392,7 +470,7 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
if ((c & ~masks[nb-1]) == patns[nb-1])
goto found;
goto invalid;
-
+
found:
c = (c & masks[nb-1]);
nread = nb - 1;
@@ -423,7 +501,7 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
goto invalid;
return c;
-
+
invalid:
generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
return (gfc_char4_t) '?';
@@ -466,7 +544,7 @@ read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
size_t m;
s = read_block_form (dtp, &width);
-
+
if (s == NULL)
return;
if (width > len)
@@ -610,7 +688,7 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
read_utf8_char4 (dtp, p, length, w);
else
read_default_char4 (dtp, p, length, w);
-
+
dtp->u.p.sf_read_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
}
@@ -651,7 +729,7 @@ next_char (st_parameter_dt *dtp, char **p, size_t *w)
if (c != ' ')
return c;
if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
- return ' '; /* return a blank to signal a null */
+ return ' '; /* return a blank to signal a null */
/* At this point, the rest of the field has to be trailing blanks */
@@ -730,19 +808,19 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
c = next_char (dtp, &p, &w);
if (c == '\0')
break;
-
+
if (c == ' ')
{
if (dtp->u.p.blank_status == BLANK_NULL)
{
/* Skip spaces. */
for ( ; w > 0; p++, w--)
- if (*p != ' ') break;
+ if (*p != ' ') break;
continue;
}
if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
-
+
if (c < '0' || c > '9')
goto bad;
@@ -778,6 +856,119 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
}
+/* read_decimal_unsigned() - almost the same as above. Checks for sign
+ and overflow are performed with -pedantic. */
+
+void
+read_decimal_unsigned (st_parameter_dt *dtp, const fnode *f, char *dest,
+ int length)
+{
+ GFC_UINTEGER_LARGEST value, old_value;
+ size_t w;
+ int negative;
+ char c, *p;
+
+ w = f->u.w;
+
+ /* This is a legacy extension, and the frontend will only allow such cases
+ * through when -fdec-format-defaults is passed.
+ */
+ if (w == (size_t) DEFAULT_WIDTH)
+ w = default_width_for_integer (length);
+
+ p = read_block_form (dtp, &w);
+
+ if (p == NULL)
+ return;
+
+ p = eat_leading_spaces (&w, p);
+ if (w == 0)
+ {
+ set_unsigned (dest, (GFC_UINTEGER_LARGEST) 0, length);
+ return;
+ }
+
+ negative = 0;
+
+ switch (*p)
+ {
+ case '-':
+ if (compile_options.pedantic)
+ goto no_sign;
+
+ negative = 1;
+
+ /* Fall through */
+
+ case '+':
+ p++;
+ if (--w == 0)
+ goto bad;
+ /* Fall through */
+
+ default:
+ break;
+ }
+
+ /* At this point we have a digit-string */
+ value = 0;
+
+ for (;;)
+ {
+ c = next_char (dtp, &p, &w);
+ if (c == '\0')
+ break;
+
+ if (c == ' ')
+ {
+ if (dtp->u.p.blank_status == BLANK_NULL)
+ {
+ /* Skip spaces. */
+ for ( ; w > 0; p++, w--)
+ if (*p != ' ') break;
+ continue;
+ }
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
+ }
+
+ if (c < '0' || c > '9')
+ goto bad;
+
+ c -= '0';
+ old_value = value;
+ value = 10 * value + c;
+ if (compile_options.pedantic && value < old_value)
+ goto overflow;
+ }
+
+ if (negative)
+ value = -value;
+
+ if (compile_options.pedantic && value > us_max (length))
+ goto overflow;
+
+ set_unsigned (dest, value, length);
+ return;
+
+ bad:
+ generate_error (&dtp->common, LIBERROR_READ_VALUE,
+ "Bad value during unsigned integer read");
+ next_record (dtp, 1);
+ return;
+
+ no_sign:
+ generate_error (&dtp->common, LIBERROR_READ_VALUE,
+ "Negative sign for unsigned integer read");
+ next_record (dtp, 1);
+ return;
+
+ overflow:
+ generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
+ "Value overflowed during unsigned integer read");
+ next_record (dtp, 1);
+
+}
+
/* read_radix()-- This function reads values for non-decimal radixes.
The difference here is that we treat the values here as unsigned
@@ -992,7 +1183,7 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
if (w == 0)
goto zero;
- /* Check for Infinity or NaN. */
+ /* Check for Infinity or NaN. */
if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
{
int seen_paren = 0;
@@ -1034,9 +1225,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
++p;
++out;
}
-
+
*out = '\0';
-
+
if (seen_paren != 0 && seen_paren != 2)
goto bad_float;
@@ -1133,7 +1324,7 @@ found_digit:
++p;
--w;
}
-
+
/* No exponent has been seen, so we use the current scale factor. */
exponent = - dtp->u.p.scale_factor;
goto done;
@@ -1171,7 +1362,7 @@ exponent:
++p;
--w;
}
-
+
/* Only allow trailing blanks. */
while (w > 0)
{
@@ -1180,7 +1371,7 @@ exponent:
++p;
--w;
}
- }
+ }
else /* BZ or BN status is enabled. */
{
while (w > 0)
@@ -1220,7 +1411,7 @@ done:
significand. */
else if (!seen_int_digit && !seen_dec_digit)
{
- notify_std (&dtp->common, GFC_STD_LEGACY,
+ notify_std (&dtp->common, GFC_STD_LEGACY,
"REAL input of style 'E+NN'");
*(out++) = '0';
}
@@ -1313,20 +1504,20 @@ read_x (st_parameter_dt *dtp, size_t n)
if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < (gfc_offset) n)
n = dtp->u.p.current_unit->bytes_left;
-
+
if (n == 0)
return;
-
+
if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
{
gfc_char4_t c;
size_t nbytes, j;
-
+
/* Proceed with decoding one character at a time. */
for (j = 0; j < n; j++)
{
c = read_utf8 (dtp, &nbytes);
-
+
/* Check for a short read and if so, break out. */
if (nbytes == 0 || c == (gfc_char4_t)0)
break;
@@ -1363,7 +1554,7 @@ read_x (st_parameter_dt *dtp, size_t n)
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
-
+
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
@@ -1377,7 +1568,7 @@ read_x (st_parameter_dt *dtp, size_t n)
goto done;
}
n++;
- }
+ }
done:
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
@@ -1386,4 +1577,3 @@ read_x (st_parameter_dt *dtp, size_t n)
dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}
-
@@ -56,6 +56,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
transfer_complex
transfer_real128
transfer_complex128
+ transfer_unsigned
and for WRITE
@@ -67,6 +68,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
transfer_complex_write
transfer_real128_write
transfer_complex128_write
+ transfer_unsigned_write
These subroutines do not return status. The *128 functions
are in the file transfer128.c.
@@ -82,6 +84,12 @@ export_proto(transfer_integer);
extern void transfer_integer_write (st_parameter_dt *, void *, int);
export_proto(transfer_integer_write);
+extern void transfer_unsigned (st_parameter_dt *, void *, int);
+export_proto(transfer_unsigned);
+
+extern void transfer_unsigned_write (st_parameter_dt *, void *, int);
+export_proto(transfer_unsigned_write);
+
extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
@@ -1410,6 +1418,9 @@ type_name (bt type)
case BT_INTEGER:
p = "INTEGER";
break;
+ case BT_UNSIGNED:
+ p = "UNSIGNED";
+ break;
case BT_LOGICAL:
p = "LOGICAL";
break;
@@ -1485,6 +1496,31 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
return 1;
}
+/* Check that the actual matches one of two expected types; issue an error
+ if that is not the case. */
+
+
+static int
+require_one_of_two_types (st_parameter_dt *dtp, bt expected1, bt expected2,
+ bt actual, const fnode *f)
+{
+ char buffer[BUFLEN];
+
+ if (actual == expected1)
+ return 0;
+
+ if (actual == expected2)
+ return 0;
+
+ snprintf (buffer, BUFLEN,
+ "Expected %s or %s for item %d in formatted transfer, got %s",
+ type_name (expected1), type_name (expected2),
+ dtp->u.p.item_count - 1, type_name (actual));
+
+ format_error (dtp, f, buffer);
+ return 1;
+
+}
/* Check that the dtio procedure required for formatted IO is present. */
@@ -1627,9 +1663,12 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
case FMT_I:
if (n == 0)
goto need_read_data;
- if (require_type (dtp, BT_INTEGER, type, f))
+ if (require_one_of_two_types (dtp, BT_INTEGER, BT_UNSIGNED, type, f))
return;
- read_decimal (dtp, f, p, kind);
+ if (type == BT_INTEGER)
+ read_decimal (dtp, f, p, kind);
+ else
+ read_decimal_unsigned (dtp, f, p, kind);
break;
case FMT_B:
@@ -2123,9 +2162,12 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
case FMT_I:
if (n == 0)
goto need_data;
- if (require_type (dtp, BT_INTEGER, type, f))
+ if (require_one_of_two_types (dtp, BT_INTEGER, BT_UNSIGNED, type, f))
return;
- write_i (dtp, f, p, kind);
+ if (type == BT_INTEGER)
+ write_i (dtp, f, p, kind);
+ else
+ write_iu (dtp, f, p, kind);
break;
case FMT_B:
@@ -2608,6 +2650,18 @@ transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
transfer_integer (dtp, p, kind);
}
+void
+transfer_unsigned (st_parameter_dt *dtp, void *p, int kind)
+{
+ wrap_scalar_transfer (dtp, BT_UNSIGNED, p, kind, kind, 1);
+}
+
+void
+transfer_unsigned_write (st_parameter_dt *dtp, void *p, int kind)
+{
+ transfer_unsigned (dtp, p, kind);
+}
+
void
transfer_real (st_parameter_dt *dtp, void *p, int kind)
{
@@ -949,7 +949,134 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
return;
}
+/* Same as above, but somewhat simpler because we only treat unsigned
+ numbers. */
+static void
+write_decimal_unsigned (st_parameter_dt *dtp, const fnode *f,
+ const char *source, int len)
+{
+ GFC_UINTEGER_LARGEST n = 0;
+ int w, m, digits, nsign, nzero, nblank;
+ char *p;
+ const char *q;
+ sign_t sign;
+ char itoa_buf[GFC_BTOA_BUF_SIZE];
+
+ w = f->u.integer.w;
+ m = f->format == FMT_G ? -1 : f->u.integer.m;
+
+ n = extract_uint (source, len);
+
+ /* Special case: */
+ if (m == 0 && n == 0)
+ {
+ if (w == 0)
+ w = 1;
+
+ p = write_block (dtp, w);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', w);
+ }
+ else
+ memset (p, ' ', w);
+ goto done;
+ }
+
+ /* Just in case somebody wants a + sign. */
+ sign = calculate_sign (dtp, false);
+ nsign = sign == S_NONE ? 0 : 1;
+
+ q = gfc_itoa (n, itoa_buf, sizeof (itoa_buf));
+ digits = strlen (q);
+
+ /* Select a width if none was specified. The idea here is to always
+ print something. */
+ if (w == DEFAULT_WIDTH)
+ w = default_width_for_integer (len);
+
+ if (w == 0)
+ w = ((digits < m) ? m : digits) + nsign;
+
+ p = write_block (dtp, w);
+ if (p == NULL)
+ return;
+
+ nzero = 0;
+ if (digits < m)
+ nzero = m - digits;
+
+ /* See if things will work. */
+
+ nblank = w - (nsign + nzero + digits);
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *)p;
+ if (nblank < 0)
+ {
+ memset4 (p4, '*', w);
+ goto done;
+ }
+
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset4 (p4, ' ', nblank);
+ p4 += nblank;
+ }
+
+ if (sign == S_PLUS)
+ *p4++ = '+';
+
+ memset4 (p4, '0', nzero);
+ p4 += nzero;
+
+ memcpy4 (p4, q, digits);
+
+ if (dtp->u.p.namelist_mode)
+ {
+ p4 += digits;
+ memset4 (p4, ' ', nblank);
+ }
+
+ return;
+ }
+
+ if (nblank < 0)
+ {
+ star_fill (p, w);
+ goto done;
+ }
+
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset (p, ' ', nblank);
+ p += nblank;
+ }
+
+ if (sign == S_PLUS)
+ *p++ = '+';
+
+ memset (p, '0', nzero);
+ p += nzero;
+
+ memcpy (p, q, digits);
+
+ if (dtp->u.p.namelist_mode)
+ {
+ p += digits;
+ memset (p, ' ', nblank);
+ }
+
+ done:
+ return;
+
+}
/* Convert hexadecimal to ASCII. */
static const char *
@@ -1240,6 +1367,11 @@ write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
write_decimal (dtp, f, p, len);
}
+void
+write_iu (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+ write_decimal_unsigned (dtp, f, p, len);
+}
void
write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
@@ -1404,6 +1536,47 @@ write_integer (st_parameter_dt *dtp, const char *source, int kind)
write_decimal (dtp, &f, source, kind);
}
+/* Write a list-directed unsigned value. We use the same formatting
+ as for integer. */
+
+static void
+write_unsigned (st_parameter_dt *dtp, const char *source, int kind)
+{
+ int width;
+ fnode f;
+
+ switch (kind)
+ {
+ case 1:
+ width = 4;
+ break;
+
+ case 2:
+ width = 6;
+ break;
+
+ case 4:
+ width = 11;
+ break;
+
+ case 8:
+ width = 20;
+ break;
+
+ case 16:
+ width = 40;
+ break;
+
+ default:
+ width = 0;
+ break;
+ }
+ f.u.integer.w = width;
+ f.u.integer.m = -1;
+ f.format = FMT_NONE;
+ write_decimal_unsigned (dtp, &f, source, kind);
+}
+
/* Write a list-directed string. We have to worry about delimiting
the strings if the file has been opened in that mode. */
@@ -1942,6 +2115,9 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
case BT_INTEGER:
write_integer (dtp, p, kind);
break;
+ case BT_UNSIGNED:
+ write_unsigned (dtp, p, kind);
+ break;
case BT_LOGICAL:
write_logical (dtp, p, kind);
break;
@@ -307,6 +307,15 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
(GFC_INTEGER_16)((((GFC_UINTEGER_16)1) << 127) - 1)
#endif
+#define GFC_UINTEGER_1_HUGE ((GFC_UINTEGER_1) -1)
+#define GFC_UINTEGER_2_HUGE ((GFC_UINTEGER_2) -1)
+#define GFC_UINTEGER_4_HUGE ((GFC_UINTEGER_4) -1)
+#define GFC_UINTEGER_8_HUGE ((GFC_UINTEGER_8) -1)
+#ifdef HAVE_GFC_UINTEGER_16
+#define GFC_UINTEGER_16_HUGE ((GFC_UINTEGER_16) -1)
+#endif
+
+
/* M{IN,AX}{LOC,VAL} need also infinities and NaNs if supported. */
#if __FLT_HAS_INFINITY__
@@ -2042,9 +2051,4 @@ extern int __snprintfieee128 (char *, size_t, const char *, ...)
#endif
-/* We always have these. */
-
-#define HAVE_GFC_UINTEGER_1 1
-#define HAVE_GFC_UINTEGER_4 1
-
#endif /* LIBGFOR_H */
@@ -38,6 +38,7 @@ for k in $possible_integer_kinds; do
echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};"
echo "#define HAVE_GFC_LOGICAL_${k}"
echo "#define HAVE_GFC_INTEGER_${k}"
+ echo "#define HAVE_GFC_UINTEGER_${k}"
echo ""
fi
rm -f tmp$$.*