mirror/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2024-11-21 13:40:47 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Implement first part of unsigned integers for Fortran.

Browse Source 
gcc/fortran/ChangeLog:

	* arith.cc (gfc_reduce_unsigned): New function.
	(gfc_arith_error): Add ARITH_UNSIGNED_TRUNCATED and
	ARITH_UNSIGNED_NEGATIVE.
	(gfc_arith_init_1): Initialize unsigned types.
	(gfc_check_unsigned_range): New function.
	(gfc_range_check): Handle unsigned types.
	(gfc_arith_uminus): Likewise.
	(gfc_arith_plus): Likewise.
	(gfc_arith_minus): Likewise.
	(gfc_arith_times): Likewise.
	(gfc_arith_divide): Likewise.
	(gfc_compare_expr): Likewise.
	(eval_intrinsic): Likewise.
	(gfc_int2int): Also convert unsigned.
	(gfc_uint2uint): New function.
	(gfc_int2uint): New function.
	(gfc_uint2int): New function.
	(gfc_uint2real): New function.
	(gfc_uint2complex): New function.
	(gfc_real2uint): New function.
	(gfc_complex2uint): New function.
	(gfc_log2uint): New function.
	(gfc_uint2log): New function.
	* arith.h (gfc_int2uint, gfc_uint2uint, gfc_uint2int, gfc_uint2real):
	Add prototypes.
	(gfc_uint2complex, gfc_real2uint, gfc_complex2uint, gfc_log2uint):
	Likewise.
	(gfc_uint2log): Likewise.
	* check.cc (gfc_boz2uint): New function
	(type_check2): New function.
	(int_or_real_or_unsigned_check): New function.
	(less_than_bitsizekind): Adjust for unsingeds.
	(less_than_bitsize2): Likewise.
	(gfc_check_allocated): Likewise.
	(gfc_check_mod): Likewise.
	(gfc_check_bge_bgt_ble_blt): Likewise.
	(gfc_check_bitfcn): Likewise.
	(gfc_check_digits): Likewise.
	(gfc_check_dshift): Likewise.
	(gfc_check_huge): Likewise.
	(gfc_check_iu): New function.
	(gfc_check_iand_ieor_ior): Adjust for unsigneds.
	(gfc_check_ibits): Likewise.
	(gfc_check_uint): New function.
	(gfc_check_ishft): Adjust for unsigneds.
	(gfc_check_ishftc): Likewise.
	(gfc_check_min_max): Likewise.
	(gfc_check_merge_bits): Likewise.
	(gfc_check_selected_int_kind): Likewise.
	(gfc_check_shift): Likewise.
	(gfc_check_mvbits): Likewise.
	(gfc_invalid_unsigned_ops): Likewise.
	* decl.cc (gfc_match_decl_type_spec): Likewise.
	* dump-parse-tree.cc (show_expr): Likewise.
	* expr.cc (gfc_get_constant_expr): Likewise.
	(gfc_copy_expr): Likewise.
	(gfc_extract_int): Likewise.
	(numeric_type): Likewise.
	* gfortran.h (enum arith): Extend with ARITH_UNSIGNED_TRUNCATED
	and ARITH_UNSIGNED_NEGATIVE.
	(enum gfc_isym_id): Extend with GFC_ISYM_SU_KIND and GFC_ISYM_UINT.
	(gfc_check_unsigned_range): New prototype-
	(gfc_arith_error): Likewise.
	(gfc_reduce_unsigned): Likewise.
	(gfc_boz2uint): Likewise.
	(gfc_invalid_unsigned_ops): Likewise.
	(gfc_convert_mpz_to_unsigned): Likewise.
	* gfortran.texi: Add some rudimentary documentation.
	* intrinsic.cc (gfc_type_letter): Adjust for unsigneds.
	(add_functions): Add uint and adjust functions to be called.
	(add_conversions): Add unsigned conversions.
	(gfc_convert_type_warn): Adjust for unsigned.
	* intrinsic.h (gfc_check_iu, gfc_check_uint, gfc_check_mod, gfc_simplify_uint,
	gfc_simplify_selected_unsigned_kind, gfc_resolve_uint): New prototypes.
	* invoke.texi: Add -funsigned.
	* iresolve.cc (gfc_resolve_dshift): Handle unsigneds.
	(gfc_resolve_iand): Handle unsigneds.
	(gfc_resolve_ibclr): Handle unsigneds.
	(gfc_resolve_ibits): Handle unsigneds.
	(gfc_resolve_ibset): Handle unsigneds.
	(gfc_resolve_ieor): Handle unsigneds.
	(gfc_resolve_ior): Handle unsigneds.
	(gfc_resolve_uint): Handle unsigneds.
	(gfc_resolve_merge_bits): Handle unsigneds.
	(gfc_resolve_not): Handle unsigneds.
	* lang.opt: Add -funsigned.
	* libgfortran.h: Add BT_UNSIGNED.
	* match.cc (gfc_match_type_spec): Match UNSIGNED.
	* misc.cc (gfc_basic_typename): Add UNSIGNED.
	(gfc_typename): Likewise.
	* primary.cc (convert_unsigned): New function.
	(match_unsigned_constant): New function.
	(gfc_match_literal_constant): Handle unsigned.
	* resolve.cc (resolve_operator): Handle unsigned.
	(resolve_ordinary_assign): Likewise.
	* simplify.cc (convert_mpz_to_unsigned): Renamed to...
	(gfc_convert_mpz_to_unsigned): and adjusted.
	(gfc_simplify_bit_size): Adjusted for unsigned.
	(compare_bitwise): Likewise.
	(gfc_simplify_bge): Likewise.
	(gfc_simplify_bgt): Likewise.
	(gfc_simplify_ble): Likewise.
	(gfc_simplify_blt): Likewise.
	(simplify_cmplx): Likewise.
	(gfc_simplify_digits): Likewise.
	(simplify_dshift): Likewise.
	(gfc_simplify_huge): Likewise.
	(gfc_simplify_iand): Likewise.
	(gfc_simplify_ibclr): Likewise.
	(gfc_simplify_ibits): Likewise.
	(gfc_simplify_ibset): Likewise.
	(gfc_simplify_ieor): Likewise.
	(gfc_simplify_uint): Likewise.
	(gfc_simplify_ior): Likewise.
	(simplify_shift): Likewise.
	(gfc_simplify_ishftc): Likewise.
	(gfc_simplify_merge_bits): Likewise.
	(min_max_choose): Likewise.
	(gfc_simplify_mod): Likewise.
	(gfc_simplify_modulo): Likewise.
	(gfc_simplify_popcnt): Likewise.
	(gfc_simplify_range): Likewise.
	(gfc_simplify_selected_unsigned_kind): Likewise.
	(gfc_convert_constant): Likewise.
	* target-memory.cc (size_unsigned): New function.
	(gfc_element_size): Adjust for unsigned.
	* trans-const.h (gfc_conv_mpz_unsigned_to_tree): Add prototype.
	* trans-const.cc (gfc_conv_mpz_unsigned_to_tree): Handle unsigneds.
	(gfc_conv_constant_to_tree): Likewise.
	* trans-decl.cc (gfc_conv_cfi_to_gfc): Put in "not yet implemented".
	* trans-expr.cc (gfc_conv_gfc_desc_to_cfi_desc): Likewise.
	* trans-stmt.cc (gfc_trans_integer_select): Handle unsigned.
	(gfc_trans_select): Likewise.
	* trans-intrinsic.cc (gfc_conv_intrinsic_mod): Handle unsigned.
	(gfc_conv_intrinsic_shift): Likewise.
	(gfc_conv_intrinsic_function): Add GFC_ISYM_UINT.
	* trans-io.cc (enum iocall): Add IOCALL_X_UNSIGNED and IOCALL_X_UNSIGNED_WRITE.
	(gfc_build_io_library_fndecls): Add transfer_unsigned and transfer_unsigned_write.
	(transfer_expr): Handle unsigneds.
	* trans-types.cc (gfc_unsinged_kinds): New array.
	(gfc_unsigned_types): Likewise.
	(gfc_init_kinds): Handle them.
	(validate_unsigned): New function.
	(gfc_validate_kind): Use it.
	(gfc_build_unsigned_type): New function.
	(gfc_init_types): Use it.
	(gfc_get_unsigned_type): New function.
	(gfc_typenode_for_spec): Handle unsigned.
	* trans-types.h (gfc_get_unsigned_type): New prototype.

libgfortran/ChangeLog:

	* gfortran.map: Add _gfortran_transfer_unsgned and
	_gfortran_transfer-signed.
	* io/io.h (set_unsigned): New prototype.
	(us_max): New prototype.
	(read_decimal_unsigned): New prototype.
	(write_iu): New prototype.
	* io/list_read.c (convert_unsigned): New function.
	(read_integer): Also handle unsigneds.
	(list_formatted_read_scalar): Handle unsigneds.
	(nml_read_obj): Likewise.
	* io/read.c (set_unsigned): New function.
	(us_max): New function.
	(read_utf8): Whitespace fixes.
	(read_default_char1): Whitespace fixes.
	(read_a_char4): Whitespace fixes.
	(next_char): Whiltespace fixes.
	(read_decimal_unsigned): New function.
	(read_f): Whitespace fixes.
	(read_x): Whitespace fixes.
	* io/transfer.c (transfer_unsigned): New function.
	(transfer_unsigned_write): New function.
	(require_one_of_two_types): New function.
	(formatted_transfer_scalar_read): Use it.
	(formatted_transfer_scalar_write): Also use it.
	* io/write.c (write_decimal_unsigned): New function.
	(write_iu): New function.
	(write_unsigned): New function.
	(list_formatted_write_scalar): Adjust for unsigneds.
	* libgfortran.h (GFC_UINTEGER_1_HUGE): Define.
	(GFC_UINTEGER_2_HUGE): Define.
	(GFC_UINTEGER_4_HUGE): Define.
	(GFC_UINTEGER_8_HUGE): Define.
	(GFC_UINTEGER_16_HUGE): Define.
	(HAVE_GFC_UINTEGER_1): Undefine (done by mk-kind-h.sh)
	(HAVE_GFC_UINTEGER_4): Likewise.
	* mk-kinds-h.sh: Add GFC_UINTEGER_*_HUGE.

gcc/testsuite/ChangeLog:

	* gfortran.dg/unsigned_1.f90: New test.
	* gfortran.dg/unsigned_10.f90: New test.
	* gfortran.dg/unsigned_11.f90: New test.
	* gfortran.dg/unsigned_12.f90: New test.
	* gfortran.dg/unsigned_13.f90: New test.
	* gfortran.dg/unsigned_14.f90: New test.
	* gfortran.dg/unsigned_15.f90: New test.
	* gfortran.dg/unsigned_16.f90: New test.
	* gfortran.dg/unsigned_17.f90: New test.
	* gfortran.dg/unsigned_18.f90: New test.
	* gfortran.dg/unsigned_19.f90: New test.
	* gfortran.dg/unsigned_2.f90: New test.
	* gfortran.dg/unsigned_20.f90: New test.
	* gfortran.dg/unsigned_21.f90: New test.
	* gfortran.dg/unsigned_22.f90: New test.
	* gfortran.dg/unsigned_23.f90: New test.
	* gfortran.dg/unsigned_24.f: New test.
	* gfortran.dg/unsigned_3.f90: New test.
	* gfortran.dg/unsigned_4.f90: New test.
	* gfortran.dg/unsigned_5.f90: New test.
	* gfortran.dg/unsigned_6.f90: New test.
	* gfortran.dg/unsigned_7.f90: New test.
	* gfortran.dg/unsigned_8.f90: New test.
	* gfortran.dg/unsigned_9.f90: New test.
This commit is contained in:
Thomas Koenig 2024-09-07 16:59:46 +02:00
parent bb8dd0980b
commit 113a6da9bf
61 changed files with 2890 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

364
gcc/fortran/arith.cc
View File

@ -58,7 +58,17 @@ 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 +96,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 +131,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 +175,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 +218,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 +390,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 +606,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 +708,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 +760,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 +799,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 +840,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 +882,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 +1229,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;
@ -1723,14 +1822,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. */
@ -2176,7 +2286,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)
@ -2184,7 +2295,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);
@ -2293,6 +2404,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. */
@ -2343,6 +2557,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. */
@ -2525,6 +2784,69 @@ 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. */
@ -2699,6 +3021,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. */
@ -2716,6 +3054,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. */

9
gcc/fortran/arith.h
View File

@ -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);

452
gcc/fortran/check.cc
View File

@ -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 constant 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)",
@ -1404,7 +1475,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. */
@ -1433,6 +1503,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)
@ -1953,11 +2056,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;
}
@ -1966,8 +2094,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;
@ -2638,7 +2774,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;
@ -2721,33 +2863,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;
}
else if (!type_check (i, 0, BT_INTEGER))
{
if (j->ts.type == BT_BOZ)
reset_boz (j);
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);
}
/* 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 (i->ts.type != BT_INTEGER)
reset_boz (j);
else if (!gfc_boz2int (j, i->ts.kind))
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);
}
if (flag_unsigned)
{
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;
@ -3018,7 +3181,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;
@ -3048,6 +3216,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)
@ -3066,11 +3249,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)
{
@ -3086,8 +3293,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;
@ -3236,6 +3451,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)
@ -3262,8 +3500,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))
@ -3276,9 +3524,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)
{
@ -3752,11 +4007,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);
@ -4198,20 +4471,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;
@ -5008,7 +5315,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)
{
@ -5104,8 +5410,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;
@ -6598,8 +6912,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;
@ -7631,3 +7954,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);
}

11
gcc/fortran/decl.cc
View File

@ -4344,6 +4344,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))
{

8
gcc/fortran/dump-parse-tree.cc
View File

@ -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);

6
gcc/fortran/expr.cc
View File

@ -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;
}

36
gcc/fortran/gfortran.h
View File

@ -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
@ -2747,6 +2753,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
{
@ -3459,7 +3484,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;
@ -3471,6 +3499,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;
@ -4012,10 +4041,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);
@ -4098,6 +4129,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 */

88
gcc/fortran/gfortran.texi
View File

@ -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,94 @@ 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, comparisons 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{-pedantic}
is in force; this prohibition is part of J3/24-116.txt.
In intrinsic procedures, unsigned arguments are typically permitted
for arguments for the data to be processed, analogous to the
use of @code{REAL} arguments. Unsigned values are prohibited
as index variables in @code{DO} loops and as array indices.
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{IBSET}
@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

49
gcc/fortran/intrinsic.cc
View File

@ -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;
@ -1656,7 +1662,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);
@ -2257,6 +2263,13 @@ 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,
@ -2686,7 +2699,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)
@ -2708,7 +2721,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);
@ -2736,7 +2749,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)
@ -2785,14 +2798,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);
@ -2953,6 +2966,18 @@ 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);
@ -4044,6 +4069,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. */
@ -5317,7 +5351,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

6
gcc/fortran/intrinsic.h
View File

@ -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 *);

5
gcc/fortran/invoke.texi
View File

@ -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

47
gcc/fortran/iresolve.cc
View File

@ -904,11 +904,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 ();
}
@ -1192,6 +1194,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))
@ -1201,7 +1204,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);
}
@ -1216,7 +1220,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);
}
@ -1225,7 +1230,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);
}
@ -1233,7 +1239,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);
}
@ -1283,6 +1290,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))
@ -1291,8 +1299,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);
}
@ -1302,6 +1311,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))
@ -1310,8 +1320,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);
}
@ -1355,6 +1366,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)
@ -1989,7 +2012,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);
}
@ -2225,7 +2251,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);
}

4
gcc/fortran/lang.opt
View File

@ -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.

2
gcc/fortran/libgfortran.h
View File

@ -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;

19
gcc/fortran/match.cc
View File

@ -2132,6 +2132,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;
@ -6207,7 +6214,9 @@ match_case_selector (gfc_case **cp)
goto cleanup;
if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
&& c->high->ts.type != BT_CHARACTER)
&& c->high->ts.type != BT_CHARACTER
&& (!flag_unsigned
|| (flag_unsigned && c->high->ts.type != BT_UNSIGNED)))
{
gfc_error ("Expression in CASE selector at %L cannot be %s",
&c->high->where, gfc_typename (&c->high->ts));
@ -6223,7 +6232,9 @@ match_case_selector (gfc_case **cp)
goto need_expr;
if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
&& c->low->ts.type != BT_CHARACTER)
&& c->low->ts.type != BT_CHARACTER
&& (!flag_unsigned
|| (flag_unsigned && c->low->ts.type != BT_UNSIGNED)))
{
gfc_error ("Expression in CASE selector at %L cannot be %s",
&c->low->where, gfc_typename (&c->low->ts));
@ -6242,7 +6253,9 @@ match_case_selector (gfc_case **cp)
if (m == MATCH_YES
&& c->high->ts.type != BT_LOGICAL
&& c->high->ts.type != BT_INTEGER
&& c->high->ts.type != BT_CHARACTER)
&& c->high->ts.type != BT_CHARACTER
&& (!flag_unsigned
|| (flag_unsigned && c->high->ts.type != BT_UNSIGNED)))
{
gfc_error ("Expression in CASE selector at %L cannot be %s",
&c->high->where, gfc_typename (c->high));

6
gcc/fortran/misc.cc
View File

@ -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;

111
gcc/fortran/primary.cc
View File

@ -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);
/* TODO 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 suffix 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;
@ -4345,4 +4455,3 @@ gfc_match_equiv_variable (gfc_expr **result)
{
return match_variable (result, 1, 0);
}

54
gcc/fortran/resolve.cc
View File

@ -4208,6 +4208,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;
}
@ -4256,11 +4263,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
@ -4463,6 +4495,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;
@ -9205,7 +9246,9 @@ resolve_select (gfc_code *code, bool select_type)
type = case_expr->ts.type;
/* F08:C830. */
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER
&& (!flag_unsigned || (flag_unsigned && type != BT_UNSIGNED)))
{
gfc_error ("Argument of SELECT statement at %L cannot be %s",
&case_expr->where, gfc_typename (case_expr));
@ -11692,6 +11735,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)
{

305
gcc/fortran/simplify.cc
View File

@ -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,46 +1715,73 @@ 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;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) < 0);
}
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,
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,50 @@ 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 is always an integer. */
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 +3933,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 +4013,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 +4117,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 +4164,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 +5223,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 +5254,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 +6233,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 +6259,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 +6286,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 +6312,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 +6768,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 +6854,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 +7535,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)
@ -8797,6 +8951,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;
@ -8811,12 +8968,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;
@ -8834,6 +9017,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;
@ -8852,6 +9038,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;
@ -8867,6 +9056,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;
@ -8895,6 +9089,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;

8
gcc/fortran/target-memory.cc
View File

@ -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;

11
gcc/fortran/trans-const.cc
View File

@ -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,

1
gcc/fortran/trans-const.h
View File

@ -20,6 +20,7 @@ along with GCC; see the file COPYING3. If not see
/* Converts between INT_CST and GMP integer representations. */
tree gfc_conv_mpz_to_tree (mpz_t, int);
tree gfc_conv_mpz_unsigned_to_tree (mpz_t, int);
tree gfc_conv_mpz_to_tree_type (mpz_t, const tree);
void gfc_conv_tree_to_mpz (mpz_t, tree);

4
gcc/fortran/trans-decl.cc
View File

@ -7099,6 +7099,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:

4
gcc/fortran/trans-expr.cc
View File

@ -5835,6 +5835,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:

22
gcc/fortran/trans-intrinsic.cc
View File

@ -3426,6 +3426,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. */
@ -6775,6 +6782,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);
@ -6783,15 +6791,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)
@ -10918,6 +10935,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;

19
gcc/fortran/trans-io.cc
View File

@ -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);
@ -2342,6 +2352,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)

20
gcc/fortran/trans-stmt.cc
View File

@ -3177,8 +3177,12 @@ gfc_trans_integer_select (gfc_code * code)
if (cp->low)
{
low = gfc_conv_mpz_to_tree (cp->low->value.integer,
cp->low->ts.kind);
if (cp->low->ts.type == BT_INTEGER)
low = gfc_conv_mpz_to_tree (cp->low->value.integer,
cp->low->ts.kind);
else
low = gfc_conv_mpz_unsigned_to_tree (cp->low->value.integer,
cp->low->ts.kind);
/* If there's only a lower bound, set the high bound to the
maximum value of the case expression. */
@ -3207,8 +3211,15 @@ gfc_trans_integer_select (gfc_code * code)
if (!cp->low
|| (mpz_cmp (cp->low->value.integer,
cp->high->value.integer) != 0))
high = gfc_conv_mpz_to_tree (cp->high->value.integer,
cp->high->ts.kind);
{
if (cp->high->ts.type == BT_INTEGER)
high = gfc_conv_mpz_to_tree (cp->high->value.integer,
cp->high->ts.kind);
else
high
= gfc_conv_mpz_unsigned_to_tree (cp->high->value.integer,
cp->high->ts.kind);
}
/* Unbounded case. */
if (!cp->low)
@ -3718,6 +3729,7 @@ gfc_trans_select (gfc_code * code)
break;
case BT_INTEGER:
case BT_UNSIGNED:
body = gfc_trans_integer_select (code);
break;

91
gcc/fortran/trans-types.cc
View File

@ -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;

1
gcc/fortran/trans-types.h
View File

@ -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);

16
gcc/testsuite/gfortran.dg/unsigned_1.f90 Normal file
View File

@ -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

56
gcc/testsuite/gfortran.dg/unsigned_10.f90 Normal file
View File

@ -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

23
gcc/testsuite/gfortran.dg/unsigned_11.f90 Normal file
View File

@ -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

18
gcc/testsuite/gfortran.dg/unsigned_12.f90 Normal file
View File

@ -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

18
gcc/testsuite/gfortran.dg/unsigned_13.f90 Normal file
View File

@ -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

18
gcc/testsuite/gfortran.dg/unsigned_14.f90 Normal file
View File

@ -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

13
gcc/testsuite/gfortran.dg/unsigned_15.f90 Normal file
View File

@ -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

10
gcc/testsuite/gfortran.dg/unsigned_16.f90 Normal file
View File

@ -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

21
gcc/testsuite/gfortran.dg/unsigned_17.f90 Normal file
View File

@ -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

40
gcc/testsuite/gfortran.dg/unsigned_18.f90 Normal file
View File

@ -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

8
gcc/testsuite/gfortran.dg/unsigned_19.f90 Normal file
View File

@ -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

20
gcc/testsuite/gfortran.dg/unsigned_2.f90 Normal file
View File

@ -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

46
gcc/testsuite/gfortran.dg/unsigned_20.f90 Normal file
View File

@ -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

13
gcc/testsuite/gfortran.dg/unsigned_21.f90 Normal file
View File

@ -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

25
gcc/testsuite/gfortran.dg/unsigned_22.f90 Normal file
View File

@ -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

39
gcc/testsuite/gfortran.dg/unsigned_23.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do run }
! { dg-options "-funsigned" }
! Test some functionality for SELECT
program main
implicit none
integer :: i
unsigned :: u
logical, dimension(-3:3) :: seen
seen = .false.
do i=-3,3
u = uint(i)
select case(u)
case (4294967293u)
if (seen(i)) error stop 1
seen(i) = .true.
case (4294967294u)
if (seen(i)) error stop 2
seen(i) = .true.
case (4294967295u)
if (seen(i)) error stop 3
seen(i) = .true.
case (0u)
if (seen(i)) error stop 4
seen(i) = .true.
case (1u)
if (seen(i)) error stop 5
seen(i) = .true.
case (2u)
if (seen(i)) error stop 6
seen(i) = .true.
case (3u)
if (seen(i)) error stop 7
seen(i) = .true.
case default
error stop 8
end select
end do
if (any(.not.seen)) error stop 9
end program main

9
gcc/testsuite/gfortran.dg/unsigned_24.f Normal file
View File

@ -0,0 +1,9 @@
! { dg-do compile }
! { dg-options "-funsigned" }
program memain
print *,12u_8
print *,1 2u_8
print *,12 u_8
print *,12u _8
print *,12u_ 8
end

10
gcc/testsuite/gfortran.dg/unsigned_3.f90 Normal file
View File

@ -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

15
gcc/testsuite/gfortran.dg/unsigned_4.f90 Normal file
View File

@ -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

123
gcc/testsuite/gfortran.dg/unsigned_5.f90 Normal file
View File

@ -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

21
gcc/testsuite/gfortran.dg/unsigned_6.f90 Normal file
View File

@ -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

26
gcc/testsuite/gfortran.dg/unsigned_7.f90 Normal file
View File

@ -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

70
gcc/testsuite/gfortran.dg/unsigned_8.f90 Normal file
View File

@ -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

32
gcc/testsuite/gfortran.dg/unsigned_9.f90 Normal file
View File

@ -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

2
libgfortran/gfortran.map
View File

@ -1775,4 +1775,6 @@ GFORTRAN_15 {
global:
_gfortran_internal_pack_class;
_gfortran_internal_unpack_class;
_gfortran_transfer_unsigned;
_gfortran_transfer_unsigned_write;
} GFORTRAN_14;

13
libgfortran/io/io.h
View File

@ -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);

135
libgfortran/io/list_read.c
View File

@ -697,8 +697,8 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
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);
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;
@ -710,8 +710,8 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
overflow:
if (length == -1)
snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list "
"input", dtp->u.p.item_count);
else
snprintf (message, IOMSG_LEN, "Integer overflow while reading item %d",
dtp->u.p.item_count);
@ -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)
{
free_saved (dtp);
return;
if (convert_integer (dtp, length, negative))
{
free_saved (dtp);
return;
}
}
else
{
if (convert_unsigned (dtp, length, negative))
{
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:

236
libgfortran/io/read.c
View File

@ -54,7 +54,7 @@ set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
}
break;
#endif
/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
/* length=10 comes about for kind=10 real/complex BOZ, see PR41711. */
case 10:
case 16:
{
@ -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;
}

62
libgfortran/io/transfer.c
View File

@ -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)
{

176
libgfortran/io/write.c
View File

@ -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;

14
libgfortran/libgfortran.h
View File

@ -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 */

1
libgfortran/mk-kinds-h.sh
View File

@ -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$$.*