procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: implement F2018 intrinsic OUT_OF_RANGE [PR115788]

Browse source 
Implementation of the Fortran 2018 standard intrinsic OUT_OF_RANGE, with
the GNU Fortran extension to unsigned integers.

Runtime code is fully inline expanded.

	PR fortran/115788

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_out_of_range): Check arguments to intrinsic.
	* expr.cc (free_expr0): Fix a memleak with unsigned literals.
	* gfortran.h (enum gfc_isym_id): Define GFC_ISYM_OUT_OF_RANGE.
	* gfortran.texi: Add OUT_OF_RANGE to list of intrinsics supporting
	UNSIGNED.
	* intrinsic.cc (add_functions): Add Fortran prototype.  Break some
	nearby lines with excessive length.
	* intrinsic.h (gfc_check_out_of_range): Add prototypes.
	* intrinsic.texi: Fortran documentation of OUT_OF_RANGE.
	* simplify.cc (gfc_simplify_out_of_range): Compile-time simplification
	of OUT_OF_RANGE.
	* trans-intrinsic.cc (gfc_conv_intrinsic_out_of_range): Generate
	inline expansion of runtime code for OUT_OF_RANGE.
	(gfc_conv_intrinsic_function): Use it.

gcc/testsuite/ChangeLog:

	* gfortran.dg/ieee/out_of_range.f90: New test.
	* gfortran.dg/out_of_range_1.f90: New test.
	* gfortran.dg/out_of_range_2.f90: New test.
	* gfortran.dg/out_of_range_3.f90: New test.
This commit is contained in:
Harald Anlauf 2025-01-12 19:26:35 +01:00
parent ed8cd42d13
commit f8eda60e12
13 changed files with 835 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
gcc/fortran/check.cc
View file

@ -4864,6 +4864,48 @@ gfc_check_null (gfc_expr *mold)
}
bool
gfc_check_out_of_range (gfc_expr *x, gfc_expr *mold, gfc_expr *round)
{
if (!int_or_real_or_unsigned_check (x, 0))
return false;
if (mold == NULL)
return false;
if (!int_or_real_or_unsigned_check (mold, 1))
return false;
if (!scalar_check (mold, 1))
return false;
if (round)
{
if (!type_check (round, 2, BT_LOGICAL))
return false;
if (!scalar_check (round, 2))
return false;
if (x->ts.type != BT_REAL
|| (mold->ts.type != BT_INTEGER && mold->ts.type != BT_UNSIGNED))
{
gfc_error ("%qs argument of %qs intrinsic at %L shall appear "
"only if %qs is of type REAL and %qs is of type "
"INTEGER or UNSIGNED",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic, &round->where,
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name);
return false;
}
}
return true;
}
bool
gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
{

1
gcc/fortran/expr.cc
View file

@ -466,6 +466,7 @@ free_expr0 (gfc_expr *e)
switch (e->ts.type)
{
case BT_INTEGER:
case BT_UNSIGNED:
mpz_clear (e->value.integer);
break;

1
gcc/fortran/gfortran.h
View file

@ -626,6 +626,7 @@ enum gfc_isym_id
GFC_ISYM_NULL,
GFC_ISYM_NUM_IMAGES,
GFC_ISYM_OR,
GFC_ISYM_OUT_OF_RANGE,
GFC_ISYM_PACK,
GFC_ISYM_PARITY,
GFC_ISYM_PERROR,

7
gcc/fortran/gfortran.texi
View file

@ -2830,6 +2830,7 @@ The following intrinsics take unsigned arguments:
@item @code{MODULO}, @pxref{MODULO}
@item @code{MVBITS}, @pxref{MVBITS}
@item @code{NOT}, @pxref{NOT}
@item @code{OUT_OF_RANGE}, @pxref{OUT_OF_RANGE}
@item @code{PRODUCT}, @pxref{PRODUCT}
@item @code{RANDOM_NUMBER}, @pxref{RANDOM_NUMBER}
@item @code{RANGE}, @pxref{RANGE}
@ -2850,12 +2851,6 @@ The following intrinsics are enabled with @option{-funsigned}:
@item @code{SELECTED_UNSIGNED_KIND}, @pxref{SELECTED_UNSIGNED_KIND}
@end itemize
The following intrinsics are not yet implemented in GNU Fortran,
but will take unsigned arguments once they have been:
@itemize @bullet
@item @code{OUT_OF_RANGE}
@end itemize
The following constants have been added to the intrinsic
@code{ISO_C_BINDING} module: @code{c_unsigned},
@code{c_unsigned_short}, @code{c_unsigned_char},

28
gcc/fortran/intrinsic.cc
View file

@ -1364,7 +1364,8 @@ add_functions (void)
*n = "n", *ncopies= "ncopies", *nm = "name", *num = "number",
*ord = "order", *p = "p", *p1 = "path1", *p2 = "path2",
*pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer",
*r = "r", *s = "s", *set = "set", *sh = "shift", *shp = "shape",
*r = "r", *rd = "round",
*s = "s", *set = "set", *sh = "shift", *shp = "shape",
*sig = "sig", *src = "source", *ssg = "substring",
*sta = "string_a", *stb = "string_b", *stg = "string",
*sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time",
@ -2789,14 +2790,16 @@ add_functions (void)
make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2,
add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_REAL, dr, GFC_STD_F2008,
gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2,
x, BT_REAL, dr, REQUIRED,
dm, BT_INTEGER, ii, OPTIONAL);
make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008);
add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95,
gfc_check_null, gfc_simplify_null, NULL,
mo, BT_INTEGER, di, OPTIONAL);
@ -2808,7 +2811,17 @@ add_functions (void)
dist, BT_INTEGER, di, OPTIONAL,
failed, BT_LOGICAL, dl, OPTIONAL);
add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
add_sym_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2018,
gfc_check_out_of_range, gfc_simplify_out_of_range, NULL,
x, BT_REAL, dr, REQUIRED,
mo, BT_INTEGER, di, REQUIRED,
rd, BT_LOGICAL, dl, OPTIONAL);
make_generic ("out_of_range", GFC_ISYM_OUT_OF_RANGE, GFC_STD_F2018);
add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_REAL, dr, GFC_STD_F95,
gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
v, BT_REAL, dr, OPTIONAL);
@ -2816,8 +2829,9 @@ add_functions (void)
make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl,
GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity,
add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2008,
gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity,
msk, BT_LOGICAL, dl, REQUIRED,
dm, BT_INTEGER, ii, OPTIONAL);

2
gcc/fortran/intrinsic.h
View file

@ -133,6 +133,7 @@ bool gfc_check_new_line (gfc_expr *);
bool gfc_check_norm2 (gfc_expr *, gfc_expr *);
bool gfc_check_null (gfc_expr *);
bool gfc_check_num_images (gfc_expr *, gfc_expr *);
bool gfc_check_out_of_range (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_parity (gfc_expr *, gfc_expr *);
bool gfc_check_precision (gfc_expr *);
@ -383,6 +384,7 @@ gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_idnint (gfc_expr *);
gfc_expr *gfc_simplify_not (gfc_expr *);
gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_out_of_range (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_parity (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_popcnt (gfc_expr *);

67
gcc/fortran/intrinsic.texi
View file

@ -252,6 +252,7 @@ Some basic guidelines for editing this document:
* @code{NULL}: NULL, Function that returns an disassociated pointer
* @code{NUM_IMAGES}: NUM_IMAGES, Number of images
* @code{OR}: OR, Bitwise logical OR
* @code{OUT_OF_RANGE}: OUT_OF_RANGE, Range check for numerical conversion
* @code{PACK}: PACK, Pack an array into an array of rank one
* @code{PARITY}: PARITY, Reduction with exclusive OR
* @code{PERROR}: PERROR, Print system error message
@ -11492,6 +11493,72 @@ Fortran 95 elemental function: @*
@node OUT_OF_RANGE
@section @code{OUT_OF_RANGE} --- Range check for numerical conversion
@fnindex OUT_OF_RANGE
@cindex range check, numerical conversion
@table @asis
@item @emph{Description}:
@code{OUT_OF_RANGE(X, MOLD[, ROUND])} determines if the value of @code{X}
can be safely converted to an object with the type of argument @code{MOLD}.
@item @emph{Standard}:
Fortran 2018
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = OUT_OF_RANGE(X, MOLD[, ROUND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{X} @tab The type shall be either @code{INTEGER}, @code{UNSIGNED}
or @code{REAL}.
@item @var{MOLD} @tab The type shall be a scalar @code{INTEGER},
@code{UNSIGNED} or @code{REAL}. If it is a variable, it need not be defined.
@item @var{ROUND} @tab (Optional) A scalar @code{LOGICAL} that shall only
be present if @var{X} is of type @code{REAL} and @var{MOLD} is of type
@code{INTEGER} or @code{UNSIGNED}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{LOGICAL}.
If @var{MOLD} is of type @code{INTEGER} or @code{UNSIGNED}, and
@var{ROUND} is absent or present with the value false, the result is
true if and only if the value of @var{X} is an IEEE infinity or NaN, or
if the integer with largest magnitude that lies between zero and @var{X}
inclusive is not representable by objects with the type and kind of
@var{MOLD}.
If @var{MOLD} is of type @code{INTEGER} or @code{UNSIGNED}, and
@var{ROUND} is present with the value true, the result is true if and
only if the value of @var{X} is an IEEE infinity or NaN, or if the
integer nearest @var{X}, or the integer of greater magnitude if two
integers are equally near to @var{X}, is not representable by objects
with the type and kind of @var{MOLD}.
Otherwise, the result is true if and only if the value of @var{X} is an IEEE
infinity or NaN that is not supported by objects of the type and kind of
@var{MOLD}, or if @var{X} is a finite number and the result of rounding the
value of @var{X} to the model for the kind of @var{MOLD} has magnitude larger
than that of the largest finite number with the same sign as @var{X} that is
representable by objects with the type and kind of @var{MOLD}.
@item @emph{Example}:
@smallexample
PROGRAM test_out_of_range
PRINT *, OUT_OF_RANGE (-128.5, 0_1) ! Will print: F
PRINT *, OUT_OF_RANGE (-128.5, 0_1, .TRUE.) ! Will print: T
END PROGRAM
@end smallexample
@end table
@node PACK
@section @code{PACK} --- Pack an array into an array of rank one
@fnindex PACK

208
gcc/fortran/simplify.cc
View file

@ -6783,6 +6783,214 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y)
}
gfc_expr *
gfc_simplify_out_of_range (gfc_expr *x, gfc_expr *mold, gfc_expr *round)
{
gfc_expr *result;
mpfr_t a;
mpz_t b;
int i, k;
bool res = false;
bool rnd = false;
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
mpfr_init (a);
switch (x->ts.type)
{
case BT_REAL:
if (mold->ts.type == BT_REAL)
{
if (mpfr_cmp (gfc_real_kinds[i].huge,
gfc_real_kinds[k].huge) <= 0)
{
/* Range of MOLD is always sufficient. */
res = false;
goto done;
}
else if (x->expr_type == EXPR_CONSTANT)
{
mpfr_neg (a, gfc_real_kinds[k].huge, GFC_RND_MODE);
res = (mpfr_cmp (x->value.real, a) < 0
|| mpfr_cmp (x->value.real, gfc_real_kinds[k].huge) > 0);
goto done;
}
}
else if (mold->ts.type == BT_INTEGER)
{
if (x->expr_type == EXPR_CONSTANT)
{
res = mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real);
if (res)
goto done;
if (round && round->expr_type != EXPR_CONSTANT)
break;
if (round && round->expr_type == EXPR_CONSTANT)
rnd = round->value.logical;
if (rnd)
mpfr_round (a, x->value.real);
else
mpfr_trunc (a, x->value.real);
mpz_init (b);
mpfr_get_z (b, a, GFC_RND_MODE);
res = (mpz_cmp (b, gfc_integer_kinds[k].min_int) < 0
|| mpz_cmp (b, gfc_integer_kinds[k].huge) > 0);
mpz_clear (b);
goto done;
}
}
else if (mold->ts.type == BT_UNSIGNED)
{
if (x->expr_type == EXPR_CONSTANT)
{
res = mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real);
if (res)
goto done;
if (round && round->expr_type != EXPR_CONSTANT)
break;
if (round && round->expr_type == EXPR_CONSTANT)
rnd = round->value.logical;
if (rnd)
mpfr_round (a, x->value.real);
else
mpfr_trunc (a, x->value.real);
mpz_init (b);
mpfr_get_z (b, a, GFC_RND_MODE);
res = (mpz_cmp (b, gfc_unsigned_kinds[k].huge) > 0
|| mpz_cmp_si (b, 0) < 0);
mpz_clear (b);
goto done;
}
}
break;
case BT_INTEGER:
gcc_assert (round == NULL);
if (mold->ts.type == BT_INTEGER)
{
if (mpz_cmp (gfc_integer_kinds[i].huge,
gfc_integer_kinds[k].huge) <= 0)
{
/* Range of MOLD is always sufficient. */
res = false;
goto done;
}
else if (x->expr_type == EXPR_CONSTANT)
{
res = (mpz_cmp (x->value.integer,
gfc_integer_kinds[k].min_int) < 0
|| mpz_cmp (x->value.integer,
gfc_integer_kinds[k].huge) > 0);
goto done;
}
}
else if (mold->ts.type == BT_UNSIGNED)
{
if (x->expr_type == EXPR_CONSTANT)
{
res = (mpz_cmp_si (x->value.integer, 0) < 0
|| mpz_cmp (x->value.integer,
gfc_unsigned_kinds[k].huge) > 0);
goto done;
}
}
else if (mold->ts.type == BT_REAL)
{
mpfr_set_z (a, gfc_integer_kinds[i].min_int, GFC_RND_MODE);
mpfr_neg (a, a, GFC_RND_MODE);
res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
/* When false, range of MOLD is always sufficient. */
if (!res)
goto done;
if (x->expr_type == EXPR_CONSTANT)
{
mpfr_set_z (a, x->value.integer, GFC_RND_MODE);
mpfr_abs (a, a, GFC_RND_MODE);
res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
goto done;
}
}
break;
case BT_UNSIGNED:
gcc_assert (round == NULL);
if (mold->ts.type == BT_UNSIGNED)
{
if (mpz_cmp (gfc_unsigned_kinds[i].huge,
gfc_unsigned_kinds[k].huge) <= 0)
{
/* Range of MOLD is always sufficient. */
res = false;
goto done;
}
else if (x->expr_type == EXPR_CONSTANT)
{
res = mpz_cmp (x->value.integer,
gfc_unsigned_kinds[k].huge) > 0;
goto done;
}
}
else if (mold->ts.type == BT_INTEGER)
{
if (mpz_cmp (gfc_unsigned_kinds[i].huge,
gfc_integer_kinds[k].huge) <= 0)
{
/* Range of MOLD is always sufficient. */
res = false;
goto done;
}
else if (x->expr_type == EXPR_CONSTANT)
{
res = mpz_cmp (x->value.integer,
gfc_integer_kinds[k].huge) > 0;
goto done;
}
}
else if (mold->ts.type == BT_REAL)
{
mpfr_set_z (a, gfc_unsigned_kinds[i].huge, GFC_RND_MODE);
res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
/* When false, range of MOLD is always sufficient. */
if (!res)
goto done;
if (x->expr_type == EXPR_CONSTANT)
{
mpfr_set_z (a, x->value.integer, GFC_RND_MODE);
res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
goto done;
}
}
break;
default:
gcc_unreachable ();
}
mpfr_clear (a);
return NULL;
done:
result = gfc_get_logical_expr (gfc_default_logical_kind, &x->where, res);
mpfr_clear (a);
return result;
}
gfc_expr *
gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
{

196
gcc/fortran/trans-intrinsic.cc
View file

@ -6991,6 +6991,198 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
TREE_TYPE (arg), arg);
}
/* Generate code for OUT_OF_RANGE. */
static void
gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
{
tree *args;
tree type;
tree tmp = NULL_TREE, tmp1, tmp2;
unsigned int num_args;
int k;
gfc_se rnd_se;
gfc_actual_arglist *arg = expr->value.function.actual;
gfc_expr *x = arg->expr;
gfc_expr *mold = arg->next->expr;
num_args = gfc_intrinsic_argument_list_length (expr);
args = XALLOCAVEC (tree, num_args);
gfc_conv_intrinsic_function_args (se, expr, args, num_args);
gfc_init_se (&rnd_se, NULL);
if (num_args == 3)
{
/* The ROUND argument is optional and shall appear only if X is
of type real and MOLD is of type integer (see edit F23/004). */
gfc_expr *round = arg->next->next->expr;
gfc_conv_expr (&rnd_se, round);
if (round->expr_type == EXPR_VARIABLE
&& round->symtree->n.sym->attr.dummy
&& round->symtree->n.sym->attr.optional)
{
tree present = gfc_conv_expr_present (round->symtree->n.sym);
rnd_se.expr = build3_loc (input_location, COND_EXPR,
logical_type_node, present,
rnd_se.expr, logical_false_node);
gfc_add_block_to_block (&se->pre, &rnd_se.pre);
}
}
else
{
/* If ROUND is absent, it is equivalent to having the value false. */
rnd_se.expr = logical_false_node;
}
type = TREE_TYPE (args[0]);
k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
switch (x->ts.type)
{
case BT_REAL:
/* X may be IEEE infinity or NaN, but the representation of MOLD may not
support infinity or NaN. */
tree finite;
finite = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_ISFINITE),
1, args[0]);
finite = convert (logical_type_node, finite);
if (mold->ts.type == BT_REAL)
{
tmp1 = build1 (ABS_EXPR, type, args[0]);
tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
mold->ts.kind, 0);
tmp = build2 (GT_EXPR, logical_type_node, tmp1,
convert (type, tmp2));
/* Check if MOLD representation supports infinity or NaN. */
bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
|| HONOR_NANS (TREE_TYPE (args[1])));
tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
infnan ? logical_false_node : logical_true_node);
}
else
{
tree rounded;
tree decl;
decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
gcc_assert (decl != NULL_TREE);
/* Round or truncate argument X, depending on the optional argument
ROUND (default: .false.). */
tmp1 = build_round_expr (args[0], type);
tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
if (mold->ts.type == BT_INTEGER)
{
tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
x->ts.kind);
tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
x->ts.kind);
}
else if (mold->ts.type == BT_UNSIGNED)
{
tmp1 = build_real_from_int_cst (type, integer_zero_node);
tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
x->ts.kind);
}
else
gcc_unreachable ();
tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
convert (type, tmp1));
tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
convert (type, tmp2));
tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
tmp);
}
break;
case BT_INTEGER:
if (mold->ts.type == BT_INTEGER)
{
tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
x->ts.kind);
tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
x->ts.kind);
tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
convert (type, tmp1));
tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
convert (type, tmp2));
tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
}
else if (mold->ts.type == BT_UNSIGNED)
{
int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
tmp = build_int_cst (type, 0);
tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
if (mpz_cmp (gfc_integer_kinds[i].huge,
gfc_unsigned_kinds[k].huge) > 0)
{
tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
x->ts.kind);
tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
convert (type, tmp2));
tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
}
}
else if (mold->ts.type == BT_REAL)
{
tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
mold->ts.kind, 0);
tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
convert (type, tmp1));
tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
convert (type, tmp2));
tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
}
else
gcc_unreachable ();
break;
case BT_UNSIGNED:
if (mold->ts.type == BT_UNSIGNED)
{
tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
x->ts.kind);
tmp = build2 (GT_EXPR, logical_type_node, args[0],
convert (type, tmp));
}
else if (mold->ts.type == BT_INTEGER)
{
tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
x->ts.kind);
tmp = build2 (GT_EXPR, logical_type_node, args[0],
convert (type, tmp));
}
else if (mold->ts.type == BT_REAL)
{
tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
mold->ts.kind, 0);
tmp = build2 (GT_EXPR, logical_type_node, args[0],
convert (type, tmp));
}
else
gcc_unreachable ();
break;
default:
gcc_unreachable ();
}
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}
/* Set or clear a single bit. */
static void
gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
@ -11750,6 +11942,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
break;
case GFC_ISYM_OUT_OF_RANGE:
gfc_conv_intrinsic_out_of_range (se, expr);
break;
case GFC_ISYM_PARITY:
gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
break;

65
gcc/testsuite/gfortran.dg/ieee/out_of_range.f90 Normal file
View file

@ -0,0 +1,65 @@
! { dg-do run }
! { dg-additional-options "-funsigned" }
!
! PR fortran/115788 - OUT_OF_RANGE
program p
use, intrinsic :: ieee_arithmetic
implicit none
real :: inf, nan
real :: r = 0.
logical :: t = .true., f = .false.
double precision :: dinf, dnan
inf = ieee_value (inf, ieee_positive_inf)
if (.not. OUT_OF_RANGE (inf, 0)) stop 1
if (.not. OUT_OF_RANGE (inf, 0, f)) stop 2
if (.not. OUT_OF_RANGE (inf, 0, t)) stop 3
if (.not. OUT_OF_RANGE (inf, 0, .false.)) stop 4
if (.not. OUT_OF_RANGE (inf, 0, .true.)) stop 5
if (.not. OUT_OF_RANGE (inf, 0U)) stop 6
if (.not. OUT_OF_RANGE (inf, 0U, f)) stop 7
if (.not. OUT_OF_RANGE (inf, 0U, t)) stop 8
if (.not. OUT_OF_RANGE (inf, 0U, .false.)) stop 9
if (.not. OUT_OF_RANGE (inf, 0U, .true.)) stop 10
if (OUT_OF_RANGE (inf, r)) stop 11
dinf = ieee_value (dinf, ieee_positive_inf)
if (OUT_OF_RANGE (inf, dinf)) stop 12
if (OUT_OF_RANGE (dinf, inf)) stop 13
if (OUT_OF_RANGE (dinf, dinf)) stop 14
call check_nan ()
contains
subroutine check_nan ()
if (.not. ieee_support_nan (nan)) return
nan = ieee_value (nan, ieee_quiet_nan)
if (.not. OUT_OF_RANGE (nan, 0)) stop 15
if (.not. OUT_OF_RANGE (nan, 0, f)) stop 16
if (.not. OUT_OF_RANGE (nan, 0, t)) stop 17
if (.not. OUT_OF_RANGE (nan, 0, .false.)) stop 18
if (.not. OUT_OF_RANGE (nan, 0, .true.)) stop 19
if (.not. OUT_OF_RANGE (nan, 0U)) stop 20
if (.not. OUT_OF_RANGE (nan, 0U, f)) stop 21
if (.not. OUT_OF_RANGE (nan, 0U, t)) stop 22
if (.not. OUT_OF_RANGE (nan, 0U, .false.)) stop 23
if (.not. OUT_OF_RANGE (nan, 0U, .true.)) stop 24
if (OUT_OF_RANGE (nan, r)) stop 25
if (.not. ieee_support_nan(dnan)) return
dnan = ieee_value(dnan, ieee_quiet_nan)
if (OUT_OF_RANGE (nan, dnan)) stop 26
if (OUT_OF_RANGE (dnan, nan)) stop 27
end subroutine check_nan
end

91
gcc/testsuite/gfortran.dg/out_of_range_1.f90 Normal file
View file

@ -0,0 +1,91 @@
! { dg-do run }
!
! PR fortran/115788 - OUT_OF_RANGE
program p
use iso_fortran_env, only: int8, int64, real32, real64
implicit none
integer :: i
integer(int8) :: i1
integer(int64) :: i8
real(real32) :: r
real(real64) :: d
logical :: t = .true., f = .false.
real, parameter :: a(*) = [-128.5, -127.5, 126.5, 127.5]
logical, parameter :: l1(*) = OUT_OF_RANGE (a, 0_int8)
logical, parameter :: l2(*) = OUT_OF_RANGE (a, 0_int8, .true.)
logical, parameter :: expect1(*) = [.false.,.false.,.false.,.false.]
logical, parameter :: expect2(*) = [.true. ,.false.,.false.,.true. ]
real :: b(size(a)) = a
! Check for correct truncation or rounding, compile-time
if (any (l1 .neqv. expect1)) stop 1
if (any (l2 .neqv. expect2)) stop 2
! Check for correct truncation or rounding, run-time
if (any (OUT_OF_RANGE (a, 0_int8, f) .neqv. expect1)) stop 3
if (any (OUT_OF_RANGE (a, 0_int8, t) .neqv. expect2)) stop 4
if (any (OUT_OF_RANGE (b, 0_int8) .neqv. expect1)) stop 5
if (any (OUT_OF_RANGE (b, 0_int8, .false.) .neqv. expect1)) stop 6
if (any (OUT_OF_RANGE (b, 0_int8, .true.) .neqv. expect2)) stop 7
if (any (OUT_OF_RANGE (b, 0_int8, f) .neqv. expect1)) stop 8
if (any (OUT_OF_RANGE (b, 0_int8, t) .neqv. expect2)) stop 9
! Miscellaneous "obvious" special cases
i1 = huge (0_int8)
i = huge (0)
i8 = huge (0_int64)
r = huge (0._real32)
d = real (r, real64)
if (OUT_OF_RANGE (huge (0_int8), r)) stop 10
if (OUT_OF_RANGE (huge (0_int8), d)) stop 11
if (OUT_OF_RANGE (huge (0_int8), i)) stop 12
if (OUT_OF_RANGE (i1, i)) stop 13
if (OUT_OF_RANGE (r, d)) stop 14
if (OUT_OF_RANGE (d, r)) stop 15
if (OUT_OF_RANGE (i, r)) stop 16
if (OUT_OF_RANGE (i8, r)) stop 17
if (OUT_OF_RANGE (i, i8)) stop 18
if (OUT_OF_RANGE (real (i1), i1,f)) stop 19
if (OUT_OF_RANGE (real (i,real64), i,f)) stop 20
if (.not. OUT_OF_RANGE (i, i1)) stop 21
if (.not. OUT_OF_RANGE (i8, i)) stop 22
if (.not. OUT_OF_RANGE (r, i8)) stop 23
if (.not. OUT_OF_RANGE (d, i8)) stop 24
! Check passing of optional argument
if (any (out_of_range_1 (b, f) .neqv. OUT_OF_RANGE (b, 0_int8, f))) stop 25
if (any (out_of_range_1 (b, t) .neqv. OUT_OF_RANGE (b, 0_int8, t))) stop 26
if (any (out_of_range_1 (b) .neqv. OUT_OF_RANGE (b, 0_int8) )) stop 27
if (any (out_of_range_2 (b,i1,f) .neqv. OUT_OF_RANGE (b, 0_int8, f))) stop 28
if (any (out_of_range_2 (b,i1,t) .neqv. OUT_OF_RANGE (b, 0_int8, t))) stop 29
if (any (out_of_range_2 (b,i1) .neqv. OUT_OF_RANGE (b, 0_int8) )) stop 30
contains
elemental logical function out_of_range_1 (x, round)
real, intent(in) :: x
logical, intent(in), optional :: round
out_of_range_1 = out_of_range (x, 0_int8, round)
end function out_of_range_1
elemental logical function out_of_range_2 (x, mold, round) result (res)
real, intent(in) :: x
class(*), intent(in) :: mold
logical, intent(in), optional :: round
select type (mold)
type is (integer(int8))
res = out_of_range (x, 0_int8, round)
class default
error stop 99
end select
end function out_of_range_2
end

115
gcc/testsuite/gfortran.dg/out_of_range_2.f90 Normal file
View file

@ -0,0 +1,115 @@
! { dg-do run }
! { dg-additional-options "-funsigned" }
!
! PR fortran/115788 - OUT_OF_RANGE
program p
use iso_fortran_env, only: int8, int64, uint8, uint64, real32, real64
implicit none
integer :: i
integer(int8) :: i1
integer(int64) :: i8
unsigned :: u
unsigned(uint8) :: u1
unsigned(uint64) :: u8
real(real32) :: r
real(real64) :: d
logical :: t = .true., f = .false.
real, parameter :: a(*) = [-0.5, 0.5, 254.5, 255.5]
logical, parameter :: l1(*) = OUT_OF_RANGE (a, 0U_uint8)
logical, parameter :: l2(*) = OUT_OF_RANGE (a, 0U_uint8, .true.)
logical, parameter :: expect1(*) = [.false.,.false.,.false.,.false.]
logical, parameter :: expect2(*) = [.true. ,.false.,.false.,.true. ]
real :: b(size(a)) = a
! Check for correct truncation or rounding, compile-time
if (any (l1 .neqv. expect1)) stop 1
if (any (l2 .neqv. expect2)) stop 2
! Check for correct truncation or rounding, run-time
if (any (OUT_OF_RANGE (a, 0U_uint8, f) .neqv. expect1)) stop 3
if (any (OUT_OF_RANGE (a, 0U_uint8, t) .neqv. expect2)) stop 4
if (any (OUT_OF_RANGE (b, 0U_uint8) .neqv. expect1)) stop 5
if (any (OUT_OF_RANGE (b, 0U_uint8, .false.) .neqv. expect1)) stop 6
if (any (OUT_OF_RANGE (b, 0U_uint8, .true.) .neqv. expect2)) stop 7
if (any (OUT_OF_RANGE (b, 0U_uint8, f) .neqv. expect1)) stop 8
if (any (OUT_OF_RANGE (b, 0U_uint8, t) .neqv. expect2)) stop 9
! Miscellaneous "obvious" special cases
u1 = huge (0U_uint8)
u = huge (0U)
u8 = huge (0U_uint64)
r = huge (0._real32)
d = real (r, real64)
if (OUT_OF_RANGE (huge (0U_uint8), r)) stop 10
if (OUT_OF_RANGE (huge (0U_uint8), d)) stop 11
if (OUT_OF_RANGE (huge (0U_uint8), u)) stop 12
if (OUT_OF_RANGE (u1, u)) stop 13
if (OUT_OF_RANGE (r, d)) stop 14
if (OUT_OF_RANGE (d, r)) stop 15
if (OUT_OF_RANGE (u, r)) stop 16
if (OUT_OF_RANGE (u8, r)) stop 17
if (OUT_OF_RANGE (u, u8)) stop 18
if (OUT_OF_RANGE (real (u1), u1,f)) stop 19
if (OUT_OF_RANGE (real (u,real64), u,f)) stop 20
if (.not. OUT_OF_RANGE (u, u1)) stop 21
if (.not. OUT_OF_RANGE (u8, u)) stop 22
if (.not. OUT_OF_RANGE (r, u8)) stop 23
if (.not. OUT_OF_RANGE (d, u8)) stop 24
! Check passing of optional argument
if (any (out_of_range_1 (b, f) .neqv. OUT_OF_RANGE (b, 0U_uint8, f))) stop 25
if (any (out_of_range_1 (b, t) .neqv. OUT_OF_RANGE (b, 0U_uint8, t))) stop 26
if (any (out_of_range_1 (b) .neqv. OUT_OF_RANGE (b, 0U_uint8) )) stop 27
if (any (out_of_range_2 (b,u1,f) .neqv. OUT_OF_RANGE (b,0U_uint8,f))) stop 28
if (any (out_of_range_2 (b,u1,t) .neqv. OUT_OF_RANGE (b,0U_uint8,t))) stop 29
if (any (out_of_range_2 (b,u1) .neqv. OUT_OF_RANGE (b,0U_uint8) )) stop 30
! Conversions between integer and unsigned
i1 = huge (0_int8)
i = huge (0)
i8 = huge (0_int64)
if (OUT_OF_RANGE (i1, u1)) stop 31
if (OUT_OF_RANGE (i, u)) stop 32
if (OUT_OF_RANGE (i8, u8)) stop 33
if (OUT_OF_RANGE (u1, i)) stop 34
if (.not. OUT_OF_RANGE (-i1, u1)) stop 35
if (.not. OUT_OF_RANGE (-i, u)) stop 36
if (.not. OUT_OF_RANGE (-i8, u8)) stop 37
if (.not. OUT_OF_RANGE (u1, i1)) stop 38
if (.not. OUT_OF_RANGE (u, i)) stop 39
if (.not. OUT_OF_RANGE (u8, i8)) stop 40
contains
elemental logical function out_of_range_1 (x, round)
real, intent(in) :: x
logical, intent(in), optional :: round
out_of_range_1 = out_of_range (x, 0U_uint8, round)
end function out_of_range_1
elemental logical function out_of_range_2 (x, mold, round) result (res)
real, intent(in) :: x
class(*), intent(in) :: mold
logical, intent(in), optional :: round
select type (mold)
type is (integer(int8))
res = out_of_range (x, 0_int8, round)
type is (unsigned(uint8))
res = out_of_range (x, 0U_uint8, round)
class default
error stop 99
end select
end function out_of_range_2
end

25
gcc/testsuite/gfortran.dg/out_of_range_3.f90 Normal file
View file

@ -0,0 +1,25 @@
! { dg-do run }
! { dg-require-effective-target fortran_integer_16 }
! { dg-additional-options "-funsigned" }
!
! PR fortran/115788 - OUT_OF_RANGE
program p
use iso_fortran_env, only: real32, real64
implicit none
unsigned(16) :: u16
real(real32) :: r
real(real64) :: d
u16 = huge(0U_16)
if (.not. OUT_OF_RANGE (u16 ,r)) stop 1
if (.not. OUT_OF_RANGE (huge(0U_16),r)) stop 2
if ( OUT_OF_RANGE (u16 ,d)) stop 3
if ( OUT_OF_RANGE (huge(0U_16),d)) stop 4
! This still fits into a 32-bit IEEE float
u16 = huge(0U_16)/65536U_16*65535U_16
if ( OUT_OF_RANGE (u16 ,r)) stop 5
if ( OUT_OF_RANGE (huge(0U_16)/65536U_16*65535U_16,r)) stop 6
end