From 39f9632844370eaf7377d9bfa182e82bbbb4b898 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Fri, 10 Jan 2025 22:16:09 +0100
Subject: [PATCH] Fortran: implement F2018 intrinsic OUT_OF_RANGE [PR115788]
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.
* 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.
---
gcc/fortran/check.cc | 42 ++++
gcc/fortran/expr.cc | 1 +
gcc/fortran/gfortran.h | 1 +
gcc/fortran/intrinsic.cc | 28 ++-
gcc/fortran/intrinsic.h | 2 +
gcc/fortran/intrinsic.texi | 64 ++++++
gcc/fortran/simplify.cc | 208 ++++++++++++++++++
gcc/fortran/trans-intrinsic.cc | 192 ++++++++++++++++
.../gfortran.dg/ieee/out_of_range.f90 | 65 ++++++
gcc/testsuite/gfortran.dg/out_of_range_1.f90 | 91 ++++++++
gcc/testsuite/gfortran.dg/out_of_range_2.f90 | 115 ++++++++++
gcc/testsuite/gfortran.dg/out_of_range_3.f90 | 25 +++
12 files changed, 827 insertions(+), 7 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/ieee/out_of_range.f90
create mode 100644 gcc/testsuite/gfortran.dg/out_of_range_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/out_of_range_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/out_of_range_3.f90
@@ -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)
{
@@ -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;
@@ -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,
@@ -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);
@@ -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 *);
@@ -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,69 @@ 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} or @code{REAL}.
+@item @var{MOLD} @tab The type shall be a scalar @code{INTEGER} 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}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{LOGICAL}.
+
+If @var{MOLD} is of type @code{INTEGER}, 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}, 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
@@ -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)
{
@@ -6991,6 +6991,194 @@ 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, 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);
+ }
+ 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));
+ }
+ 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 +11938,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;
new file mode 100644
@@ -0,0 +1,65 @@
+! { dg-do run }
+! { dg-additional-options "-funsigned -fno-finite-math-only" }
+!
+! 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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
--
2.43.0