2151 lines
74 KiB
Diff
2151 lines
74 KiB
Diff
|
From f68aa5f6a6d710f12005ca2ee34f27d6a8a68745 Mon Sep 17 00:00:00 2001
|
||
|
From: Mark Eggleston <markeggleston@gcc.gnu.org>
|
||
|
Date: Mon, 3 Feb 2020 09:38:24 +0000
|
||
|
Subject: [PATCH 08/10] Support type promotion in calls to intrinsics
|
||
|
|
||
|
Use -fdec-promotion or -fdec to enable this feature.
|
||
|
|
||
|
Merged 2 commits: worked on by Ben Brewer <ben.brewer@codethink.co.uk>,
|
||
|
Francisco Redondo Marchena <francisco.marchena@codethink.co.uk and
|
||
|
Jeff Law <law@redhat.com>
|
||
|
|
||
|
Re-worked by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
---
|
||
|
gcc/fortran/check.c | 71 +++++-
|
||
|
gcc/fortran/intrinsic.c | 5 +
|
||
|
gcc/fortran/iresolve.c | 91 ++++---
|
||
|
gcc/fortran/lang.opt | 4 +
|
||
|
gcc/fortran/options.c | 1 +
|
||
|
gcc/fortran/simplify.c | 266 ++++++++++++++++-----
|
||
|
...ec_intrinsic_int_real_array_const_promotion_1.f | 18 ++
|
||
|
...ec_intrinsic_int_real_array_const_promotion_2.f | 18 ++
|
||
|
...ec_intrinsic_int_real_array_const_promotion_3.f | 18 ++
|
||
|
.../dec_intrinsic_int_real_const_promotion_1.f | 90 +++++++
|
||
|
.../dec_intrinsic_int_real_const_promotion_2.f | 90 +++++++
|
||
|
.../dec_intrinsic_int_real_const_promotion_3.f | 92 +++++++
|
||
|
.../dec_intrinsic_int_real_promotion_1.f | 130 ++++++++++
|
||
|
.../dec_intrinsic_int_real_promotion_2.f | 130 ++++++++++
|
||
|
.../dec_intrinsic_int_real_promotion_3.f | 130 ++++++++++
|
||
|
.../dec_intrinsic_int_real_promotion_4.f | 118 +++++++++
|
||
|
.../dec_intrinsic_int_real_promotion_5.f | 118 +++++++++
|
||
|
.../dec_intrinsic_int_real_promotion_6.f | 118 +++++++++
|
||
|
.../dec_intrinsic_int_real_promotion_7.f | 118 +++++++++
|
||
|
gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f | 40 ++++
|
||
|
gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f | 40 ++++
|
||
|
gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f | 39 +++
|
||
|
22 files changed, 1654 insertions(+), 91 deletions(-)
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f
|
||
|
create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f
|
||
|
|
||
|
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
|
||
|
index 4c0b83e8e6f..d428068674f 100644
|
||
|
--- a/gcc/fortran/check.c
|
||
|
+++ b/gcc/fortran/check.c
|
||
|
@@ -1393,12 +1393,40 @@ gfc_check_allocated (gfc_expr *array)
|
||
|
}
|
||
|
|
||
|
|
||
|
+/* Check function where both arguments must be real or integer
|
||
|
+ and warn if they are different types. */
|
||
|
+
|
||
|
+bool
|
||
|
+check_int_real_promotion (gfc_expr *a, gfc_expr *b)
|
||
|
+{
|
||
|
+ gfc_expr *i;
|
||
|
+
|
||
|
+ if (!int_or_real_check (a, 0))
|
||
|
+ return false;
|
||
|
+
|
||
|
+ if (!int_or_real_check (b, 1))
|
||
|
+ return false;
|
||
|
+
|
||
|
+ if (a->ts.type != b->ts.type)
|
||
|
+ {
|
||
|
+ i = (a->ts.type != BT_REAL ? a : b);
|
||
|
+ gfc_warning_now (OPT_Wconversion, "Conversion from INTEGER to REAL "
|
||
|
+ "at %L might lose precision", &i->where);
|
||
|
+ }
|
||
|
+
|
||
|
+ 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. */
|
||
|
|
||
|
bool
|
||
|
gfc_check_a_p (gfc_expr *a, gfc_expr *p)
|
||
|
{
|
||
|
+ if (flag_dec_promotion)
|
||
|
+ return check_int_real_promotion (a, p);
|
||
|
+
|
||
|
if (!int_or_real_check (a, 0))
|
||
|
return false;
|
||
|
|
||
|
@@ -3716,6 +3744,41 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
|
||
|
}
|
||
|
|
||
|
|
||
|
+/* Check function where all arguments of an argument list must be real
|
||
|
+ or integer. */
|
||
|
+
|
||
|
+static bool
|
||
|
+check_rest_int_real (gfc_actual_arglist *arglist)
|
||
|
+{
|
||
|
+ gfc_actual_arglist *arg, *tmp;
|
||
|
+ gfc_expr *x;
|
||
|
+ int m, n;
|
||
|
+
|
||
|
+ if (!min_max_args (arglist))
|
||
|
+ return false;
|
||
|
+
|
||
|
+ for (arg = arglist, n=1; arg; arg = arg->next, n++)
|
||
|
+ {
|
||
|
+ x = arg->expr;
|
||
|
+ if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
|
||
|
+ {
|
||
|
+ gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
|
||
|
+ "INTEGER or REAL", n, gfc_current_intrinsic, &x->where);
|
||
|
+ return false;
|
||
|
+ }
|
||
|
+
|
||
|
+ for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
|
||
|
+ if (!gfc_check_conformance (tmp->expr, x,
|
||
|
+ "arguments 'a%d' and 'a%d' for "
|
||
|
+ "intrinsic '%s'", m, n,
|
||
|
+ gfc_current_intrinsic))
|
||
|
+ return false;
|
||
|
+ }
|
||
|
+
|
||
|
+ return true;
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
bool
|
||
|
gfc_check_min_max (gfc_actual_arglist *arg)
|
||
|
{
|
||
|
@@ -3740,7 +3803,10 @@ gfc_check_min_max (gfc_actual_arglist *arg)
|
||
|
return false;
|
||
|
}
|
||
|
|
||
|
- return check_rest (x->ts.type, x->ts.kind, arg);
|
||
|
+ if (flag_dec_promotion && x->ts.type != BT_CHARACTER)
|
||
|
+ return check_rest_int_real (arg);
|
||
|
+ else
|
||
|
+ return check_rest (x->ts.type, x->ts.kind, arg);
|
||
|
}
|
||
|
|
||
|
|
||
|
@@ -5112,6 +5178,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift)
|
||
|
bool
|
||
|
gfc_check_sign (gfc_expr *a, gfc_expr *b)
|
||
|
{
|
||
|
+ if (flag_dec_promotion)
|
||
|
+ return check_int_real_promotion (a, b);
|
||
|
+
|
||
|
if (!int_or_real_check (a, 0))
|
||
|
return false;
|
||
|
|
||
|
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
|
||
|
index 30f9f14572b..1591f9dfc2f 100644
|
||
|
--- a/gcc/fortran/intrinsic.c
|
||
|
+++ b/gcc/fortran/intrinsic.c
|
||
|
@@ -4430,6 +4430,11 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
|
||
|
if (ts.kind == 0)
|
||
|
ts.kind = actual->expr->ts.kind;
|
||
|
|
||
|
+ /* If kind promotion is allowed don't check for kind if it is smaller */
|
||
|
+ if (flag_dec_promotion && ts.type == BT_INTEGER)
|
||
|
+ if (actual->expr->ts.kind < ts.kind)
|
||
|
+ ts.kind = actual->expr->ts.kind;
|
||
|
+
|
||
|
if (!gfc_compare_types (&ts, &actual->expr->ts))
|
||
|
{
|
||
|
if (error_flag)
|
||
|
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
|
||
|
index 73769615c20..df8a2fd4119 100644
|
||
|
--- a/gcc/fortran/iresolve.c
|
||
|
+++ b/gcc/fortran/iresolve.c
|
||
|
@@ -817,19 +817,22 @@ gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
|
||
|
void
|
||
|
gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
|
||
|
{
|
||
|
- f->ts.type = a->ts.type;
|
||
|
if (p != NULL)
|
||
|
- f->ts.kind = gfc_kind_max (a,p);
|
||
|
- else
|
||
|
- f->ts.kind = a->ts.kind;
|
||
|
-
|
||
|
- if (p != NULL && a->ts.kind != p->ts.kind)
|
||
|
{
|
||
|
- if (a->ts.kind == gfc_kind_max (a,p))
|
||
|
- gfc_convert_type (p, &a->ts, 2);
|
||
|
+ f->ts.kind = gfc_kind_max (a,p);
|
||
|
+ if (a->ts.type == BT_REAL || p->ts.type == BT_REAL)
|
||
|
+ f->ts.type = BT_REAL;
|
||
|
else
|
||
|
- gfc_convert_type (a, &p->ts, 2);
|
||
|
+ f->ts.type = BT_INTEGER;
|
||
|
+
|
||
|
+ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (a, &f->ts, 2);
|
||
|
+
|
||
|
+ if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (p, &f->ts, 2);
|
||
|
}
|
||
|
+ else
|
||
|
+ f->ts = a->ts;
|
||
|
|
||
|
f->value.function.name
|
||
|
= gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
|
||
|
@@ -1610,14 +1613,17 @@ gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
|
||
|
/* Find the largest type kind. */
|
||
|
for (a = args->next; a; a = a->next)
|
||
|
{
|
||
|
+ if (a->expr-> ts.type == BT_REAL)
|
||
|
+ f->ts.type = BT_REAL;
|
||
|
+
|
||
|
if (a->expr->ts.kind > f->ts.kind)
|
||
|
f->ts.kind = a->expr->ts.kind;
|
||
|
}
|
||
|
|
||
|
- /* Convert all parameters to the required kind. */
|
||
|
+ /* Convert all parameters to the required type and/or kind. */
|
||
|
for (a = args; a; a = a->next)
|
||
|
{
|
||
|
- if (a->expr->ts.kind != f->ts.kind)
|
||
|
+ if (a->expr->ts.type != f->ts.type || a->expr->ts.kind != f->ts.kind)
|
||
|
gfc_convert_type (a->expr, &f->ts, 2);
|
||
|
}
|
||
|
|
||
|
@@ -2110,19 +2116,22 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
|
||
|
void
|
||
|
gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
|
||
|
{
|
||
|
- f->ts.type = a->ts.type;
|
||
|
if (p != NULL)
|
||
|
- f->ts.kind = gfc_kind_max (a,p);
|
||
|
- else
|
||
|
- f->ts.kind = a->ts.kind;
|
||
|
-
|
||
|
- if (p != NULL && a->ts.kind != p->ts.kind)
|
||
|
{
|
||
|
- if (a->ts.kind == gfc_kind_max (a,p))
|
||
|
- gfc_convert_type (p, &a->ts, 2);
|
||
|
+ f->ts.kind = gfc_kind_max (a,p);
|
||
|
+ if (a->ts.type == BT_REAL || p->ts.type == BT_REAL)
|
||
|
+ f->ts.type = BT_REAL;
|
||
|
else
|
||
|
- gfc_convert_type (a, &p->ts, 2);
|
||
|
+ f->ts.type = BT_INTEGER;
|
||
|
+
|
||
|
+ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (a, &f->ts, 2);
|
||
|
+
|
||
|
+ if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (p, &f->ts, 2);
|
||
|
}
|
||
|
+ else
|
||
|
+ f->ts = a->ts;
|
||
|
|
||
|
f->value.function.name
|
||
|
= gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
|
||
|
@@ -2132,19 +2141,22 @@ gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
|
||
|
void
|
||
|
gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
|
||
|
{
|
||
|
- f->ts.type = a->ts.type;
|
||
|
if (p != NULL)
|
||
|
- f->ts.kind = gfc_kind_max (a,p);
|
||
|
- else
|
||
|
- f->ts.kind = a->ts.kind;
|
||
|
-
|
||
|
- if (p != NULL && a->ts.kind != p->ts.kind)
|
||
|
{
|
||
|
- if (a->ts.kind == gfc_kind_max (a,p))
|
||
|
- gfc_convert_type (p, &a->ts, 2);
|
||
|
+ f->ts.kind = gfc_kind_max (a,p);
|
||
|
+ if (a->ts.type == BT_REAL || p->ts.type == BT_REAL)
|
||
|
+ f->ts.type = BT_REAL;
|
||
|
else
|
||
|
- gfc_convert_type (a, &p->ts, 2);
|
||
|
+ f->ts.type = BT_INTEGER;
|
||
|
+
|
||
|
+ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (a, &f->ts, 2);
|
||
|
+
|
||
|
+ if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (p, &f->ts, 2);
|
||
|
}
|
||
|
+ else
|
||
|
+ f->ts = a->ts;
|
||
|
|
||
|
f->value.function.name
|
||
|
= gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
|
||
|
@@ -2519,9 +2531,26 @@ gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
|
||
|
|
||
|
|
||
|
void
|
||
|
-gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
|
||
|
+gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b)
|
||
|
{
|
||
|
- f->ts = a->ts;
|
||
|
+ if (b != NULL)
|
||
|
+ {
|
||
|
+ f->ts.kind = gfc_kind_max (a, b);
|
||
|
+ if (a->ts.type == BT_REAL || b->ts.type == BT_REAL)
|
||
|
+ f->ts.type = BT_REAL;
|
||
|
+ else
|
||
|
+ f->ts.type = BT_INTEGER;
|
||
|
+
|
||
|
+ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (a, &f->ts, 2);
|
||
|
+
|
||
|
+ if (b->ts.kind != f->ts.kind || b->ts.type != f->ts.type)
|
||
|
+ gfc_convert_type (b, &f->ts, 2);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ f->ts = a->ts;
|
||
|
+ }
|
||
|
f->value.function.name
|
||
|
= gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
|
||
|
}
|
||
|
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
|
||
|
index 0a6b4263e22..aceef2aa180 100644
|
||
|
--- a/gcc/fortran/lang.opt
|
||
|
+++ b/gcc/fortran/lang.opt
|
||
|
@@ -501,6 +501,10 @@ fdec-old-init
|
||
|
Fortran Var(flag_dec_old_init)
|
||
|
Enable support for old style initializers in derived types.
|
||
|
|
||
|
+fdec-promotion
|
||
|
+Fortran Var(flag_dec_promotion)
|
||
|
+Add support for type promotion in intrinsic arguments.
|
||
|
+
|
||
|
fdec-structure
|
||
|
Fortran Var(flag_dec_structure)
|
||
|
Enable support for DEC STRUCTURE/RECORD.
|
||
|
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
|
||
|
index 86b28cfe3e6..82e5c9edf4b 100644
|
||
|
--- a/gcc/fortran/options.c
|
||
|
+++ b/gcc/fortran/options.c
|
||
|
@@ -82,6 +82,7 @@ set_dec_flags (int value)
|
||
|
SET_BITFLAG (flag_dec_old_init, value, value);
|
||
|
SET_BITFLAG (flag_dec_override_kind, value, value);
|
||
|
SET_BITFLAG (flag_dec_non_logical_if, value, value);
|
||
|
+ SET_BITFLAG (flag_dec_promotion, value, value);
|
||
|
}
|
||
|
|
||
|
/* Finalize DEC flags. */
|
||
|
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
|
||
|
index 248fe05ee48..cebc811b233 100644
|
||
|
--- a/gcc/fortran/simplify.c
|
||
|
+++ b/gcc/fortran/simplify.c
|
||
|
@@ -2301,39 +2301,79 @@ gfc_simplify_digits (gfc_expr *x)
|
||
|
}
|
||
|
|
||
|
|
||
|
+/* Simplify function which sets the floating-point value of ar from
|
||
|
+ the value of a independently if a is integer of real. */
|
||
|
+
|
||
|
+static void
|
||
|
+simplify_int_real_promotion (const gfc_expr *a, const gfc_expr *b, mpfr_t *ar)
|
||
|
+{
|
||
|
+ if (a->ts.type == BT_REAL)
|
||
|
+ {
|
||
|
+ mpfr_init2 (*ar, (a->ts.kind * 8));
|
||
|
+ mpfr_set (*ar, a->value.real, GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ mpfr_init2 (*ar, (b->ts.kind * 8));
|
||
|
+ mpfr_set_z (*ar, a->value.integer, GFC_RND_MODE);
|
||
|
+ }
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+/* Simplify function which promotes a and b arguments from integer to real if
|
||
|
+ required in ar and br floating-point values. This function returns true if
|
||
|
+ a or b are reals and false otherwise. */
|
||
|
+
|
||
|
+static bool
|
||
|
+simplify_int_real_promotion2 (const gfc_expr *a, const gfc_expr *b, mpfr_t *ar,
|
||
|
+ mpfr_t *br)
|
||
|
+{
|
||
|
+ if (a->ts.type != BT_REAL && b->ts.type != BT_REAL)
|
||
|
+ return false;
|
||
|
+
|
||
|
+ simplify_int_real_promotion (a, b, ar);
|
||
|
+ simplify_int_real_promotion (b, a, br);
|
||
|
+
|
||
|
+ return true;
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
gfc_expr *
|
||
|
gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
|
||
|
{
|
||
|
gfc_expr *result;
|
||
|
int kind;
|
||
|
|
||
|
+ mpfr_t xr;
|
||
|
+ mpfr_t yr;
|
||
|
+
|
||
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
||
|
return NULL;
|
||
|
|
||
|
- kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
|
||
|
- result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
|
||
|
-
|
||
|
- switch (x->ts.type)
|
||
|
+ if ((x->ts.type != BT_REAL && x->ts.type != BT_INTEGER)
|
||
|
+ || (y->ts.type != BT_REAL && y->ts.type != BT_INTEGER))
|
||
|
{
|
||
|
- case BT_INTEGER:
|
||
|
- if (mpz_cmp (x->value.integer, y->value.integer) > 0)
|
||
|
- mpz_sub (result->value.integer, x->value.integer, y->value.integer);
|
||
|
- else
|
||
|
- mpz_set_ui (result->value.integer, 0);
|
||
|
-
|
||
|
- break;
|
||
|
-
|
||
|
- case BT_REAL:
|
||
|
- if (mpfr_cmp (x->value.real, y->value.real) > 0)
|
||
|
- mpfr_sub (result->value.real, x->value.real, y->value.real,
|
||
|
- GFC_RND_MODE);
|
||
|
- else
|
||
|
- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
||
|
+ gfc_internal_error ("gfc_simplify_dim(): Bad arguments");
|
||
|
+ return NULL;
|
||
|
+ }
|
||
|
|
||
|
- break;
|
||
|
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
|
||
|
|
||
|
- default:
|
||
|
- gfc_internal_error ("gfc_simplify_dim(): Bad type");
|
||
|
+ if (simplify_int_real_promotion2 (x, y, &xr, &yr))
|
||
|
+ {
|
||
|
+ result = gfc_get_constant_expr (BT_REAL, kind, &x->where);
|
||
|
+ if (mpfr_cmp (xr, yr) > 0)
|
||
|
+ mpfr_sub (result->value.real, xr, yr, GFC_RND_MODE);
|
||
|
+ else
|
||
|
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
|
||
|
+ if (mpz_cmp (x->value.integer, y->value.integer) > 0)
|
||
|
+ mpz_sub (result->value.integer, x->value.integer, y->value.integer);
|
||
|
+ else
|
||
|
+ mpz_set_ui (result->value.integer, 0);
|
||
|
}
|
||
|
|
||
|
return range_check (result, "DIM");
|
||
|
@@ -4921,13 +4961,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
|
||
|
{
|
||
|
int ret;
|
||
|
|
||
|
+ mpfr_t *arp;
|
||
|
+ mpfr_t *erp;
|
||
|
+ mpfr_t ar;
|
||
|
+ mpfr_t er;
|
||
|
+
|
||
|
+ if (arg->ts.type != extremum->ts.type)
|
||
|
+ {
|
||
|
+ if (arg->ts.type == BT_REAL)
|
||
|
+ {
|
||
|
+ arp = &arg->value.real;
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ mpfr_init2 (ar, (arg->ts.kind * 8));
|
||
|
+ mpfr_set_z (ar, arg->value.integer, GFC_RND_MODE);
|
||
|
+ arp = &ar;
|
||
|
+ }
|
||
|
+
|
||
|
+ if (extremum->ts.type == BT_REAL)
|
||
|
+ {
|
||
|
+ erp = &extremum->value.real;
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ mpfr_init2 (er, (extremum->ts.kind * 8));
|
||
|
+ mpfr_set_z (er, extremum->value.integer, GFC_RND_MODE);
|
||
|
+ erp = &er;
|
||
|
+ }
|
||
|
+
|
||
|
+ if (mpfr_nan_p (*erp))
|
||
|
+ {
|
||
|
+ ret = 1;
|
||
|
+ extremum->ts.type = arg->ts.type;
|
||
|
+ extremum->ts.kind = arg->ts.kind;
|
||
|
+ if (arg->ts.type == BT_INTEGER)
|
||
|
+ {
|
||
|
+ mpz_init2 (extremum->value.integer, (arg->ts.kind * 8));
|
||
|
+ mpz_set (extremum->value.integer, arg->value.integer);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ mpfr_init2 (extremum->value.real, (arg->ts.kind * 8));
|
||
|
+ mpfr_set (extremum->value.real, *arp, GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ }
|
||
|
+ else if (mpfr_nan_p (*arp))
|
||
|
+ ret = -1;
|
||
|
+ else
|
||
|
+ {
|
||
|
+ ret = mpfr_cmp (*arp, *erp) * sign;
|
||
|
+ if (ret > 0)
|
||
|
+ {
|
||
|
+ extremum->ts.type = arg->ts.type;
|
||
|
+ extremum->ts.kind = arg->ts.kind;
|
||
|
+ if (arg->ts.type == BT_INTEGER)
|
||
|
+ {
|
||
|
+ mpz_init2 (extremum->value.integer, (arg->ts.kind * 8));
|
||
|
+ mpz_set (extremum->value.integer, arg->value.integer);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ mpfr_init2 (extremum->value.real, (arg->ts.kind * 8));
|
||
|
+ mpfr_set (extremum->value.real, *arp, GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ }
|
||
|
+ }
|
||
|
+
|
||
|
+ return ret;
|
||
|
+ }
|
||
|
+
|
||
|
switch (arg->ts.type)
|
||
|
{
|
||
|
case BT_INTEGER:
|
||
|
ret = mpz_cmp (arg->value.integer,
|
||
|
extremum->value.integer) * sign;
|
||
|
if (ret > 0)
|
||
|
- mpz_set (extremum->value.integer, arg->value.integer);
|
||
|
+ {
|
||
|
+ if (arg->ts.kind > extremum->ts.kind)
|
||
|
+ extremum->ts.kind = arg->ts.kind;
|
||
|
+ mpz_set (extremum->value.integer, arg->value.integer);
|
||
|
+ }
|
||
|
break;
|
||
|
|
||
|
case BT_REAL:
|
||
|
@@ -5876,7 +5990,9 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
|
||
|
gfc_expr *result;
|
||
|
int kind;
|
||
|
|
||
|
- /* First check p. */
|
||
|
+ mpfr_t ar;
|
||
|
+ mpfr_t pr;
|
||
|
+
|
||
|
if (p->expr_type != EXPR_CONSTANT)
|
||
|
return NULL;
|
||
|
|
||
|
@@ -5887,18 +6003,18 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
|
||
|
if (mpz_cmp_ui (p->value.integer, 0) == 0)
|
||
|
{
|
||
|
gfc_error ("Argument %qs of MOD at %L shall not be zero",
|
||
|
- "P", &p->where);
|
||
|
+ "P", &p->where);
|
||
|
return &gfc_bad_expr;
|
||
|
}
|
||
|
- break;
|
||
|
+ break;
|
||
|
case BT_REAL:
|
||
|
if (mpfr_cmp_ui (p->value.real, 0) == 0)
|
||
|
{
|
||
|
gfc_error ("Argument %qs of MOD at %L shall not be zero",
|
||
|
- "P", &p->where);
|
||
|
+ "P", &p->where);
|
||
|
return &gfc_bad_expr;
|
||
|
- }
|
||
|
- break;
|
||
|
+ }
|
||
|
+ break;
|
||
|
default:
|
||
|
gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
|
||
|
}
|
||
|
@@ -5906,16 +6022,24 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
|
||
|
if (a->expr_type != EXPR_CONSTANT)
|
||
|
return NULL;
|
||
|
|
||
|
+ if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER)
|
||
|
+ {
|
||
|
+ gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
|
||
|
+ return NULL;
|
||
|
+ }
|
||
|
+
|
||
|
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_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
|
||
|
- else
|
||
|
+ if (simplify_int_real_promotion2 (a, p, &ar, &pr))
|
||
|
{
|
||
|
+ result = gfc_get_constant_expr (BT_REAL, kind, &a->where);
|
||
|
gfc_set_model_kind (kind);
|
||
|
- mpfr_fmod (result->value.real, a->value.real, p->value.real,
|
||
|
- GFC_RND_MODE);
|
||
|
+ mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where);
|
||
|
+ mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
|
||
|
}
|
||
|
|
||
|
return range_check (result, "MOD");
|
||
|
@@ -5928,7 +6052,9 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
|
||
|
gfc_expr *result;
|
||
|
int kind;
|
||
|
|
||
|
- /* First check p. */
|
||
|
+ mpfr_t ar;
|
||
|
+ mpfr_t pr;
|
||
|
+
|
||
|
if (p->expr_type != EXPR_CONSTANT)
|
||
|
return NULL;
|
||
|
|
||
|
@@ -5939,44 +6065,52 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
|
||
|
if (mpz_cmp_ui (p->value.integer, 0) == 0)
|
||
|
{
|
||
|
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
|
||
|
- "P", &p->where);
|
||
|
+ "P", &p->where);
|
||
|
return &gfc_bad_expr;
|
||
|
}
|
||
|
- break;
|
||
|
+ break;
|
||
|
case BT_REAL:
|
||
|
if (mpfr_cmp_ui (p->value.real, 0) == 0)
|
||
|
{
|
||
|
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
|
||
|
- "P", &p->where);
|
||
|
+ "P", &p->where);
|
||
|
return &gfc_bad_expr;
|
||
|
- }
|
||
|
- break;
|
||
|
+ }
|
||
|
+ break;
|
||
|
default:
|
||
|
gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
|
||
|
}
|
||
|
|
||
|
+ if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER)
|
||
|
+ {
|
||
|
+ gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
|
||
|
+ return NULL;
|
||
|
+ }
|
||
|
+
|
||
|
if (a->expr_type != EXPR_CONSTANT)
|
||
|
return NULL;
|
||
|
|
||
|
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);
|
||
|
- else
|
||
|
+ if (simplify_int_real_promotion2 (a, p, &ar, &pr))
|
||
|
{
|
||
|
+ result = gfc_get_constant_expr (BT_REAL, kind, &a->where);
|
||
|
gfc_set_model_kind (kind);
|
||
|
- mpfr_fmod (result->value.real, a->value.real, p->value.real,
|
||
|
- GFC_RND_MODE);
|
||
|
+ mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE);
|
||
|
if (mpfr_cmp_ui (result->value.real, 0) != 0)
|
||
|
- {
|
||
|
- if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
|
||
|
- mpfr_add (result->value.real, result->value.real, p->value.real,
|
||
|
- GFC_RND_MODE);
|
||
|
- }
|
||
|
- else
|
||
|
- mpfr_copysign (result->value.real, result->value.real,
|
||
|
- p->value.real, GFC_RND_MODE);
|
||
|
+ {
|
||
|
+ if (mpfr_signbit (ar) != mpfr_signbit (pr))
|
||
|
+ mpfr_add (result->value.real, result->value.real, pr,
|
||
|
+ GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ mpfr_copysign (result->value.real, result->value.real, pr,
|
||
|
+ GFC_RND_MODE);
|
||
|
+ }
|
||
|
+ else
|
||
|
+ {
|
||
|
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where);
|
||
|
+ mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
|
||
|
}
|
||
|
|
||
|
return range_check (result, "MODULO");
|
||
|
@@ -7532,27 +7666,41 @@ gfc_expr *
|
||
|
gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
|
||
|
{
|
||
|
gfc_expr *result;
|
||
|
+ bool neg;
|
||
|
|
||
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
||
|
return NULL;
|
||
|
|
||
|
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
|
||
|
|
||
|
+ switch (y->ts.type)
|
||
|
+ {
|
||
|
+ case BT_INTEGER:
|
||
|
+ neg = (mpz_sgn (y->value.integer) < 0);
|
||
|
+ break;
|
||
|
+
|
||
|
+ case BT_REAL:
|
||
|
+ neg = (mpfr_sgn (y->value.real) < 0);
|
||
|
+ break;
|
||
|
+
|
||
|
+ default:
|
||
|
+ gfc_internal_error ("Bad type in gfc_simplify_sign");
|
||
|
+ }
|
||
|
+
|
||
|
switch (x->ts.type)
|
||
|
{
|
||
|
case BT_INTEGER:
|
||
|
mpz_abs (result->value.integer, x->value.integer);
|
||
|
- if (mpz_sgn (y->value.integer) < 0)
|
||
|
+ if (neg)
|
||
|
mpz_neg (result->value.integer, result->value.integer);
|
||
|
break;
|
||
|
|
||
|
case BT_REAL:
|
||
|
- if (flag_sign_zero)
|
||
|
+ if (flag_sign_zero && y->ts.type == BT_REAL)
|
||
|
mpfr_copysign (result->value.real, x->value.real, y->value.real,
|
||
|
- GFC_RND_MODE);
|
||
|
+ GFC_RND_MODE);
|
||
|
else
|
||
|
- mpfr_setsign (result->value.real, x->value.real,
|
||
|
- mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
|
||
|
+ mpfr_setsign (result->value.real, x->value.real, neg, GFC_RND_MODE);
|
||
|
break;
|
||
|
|
||
|
default:
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..25763852139
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f
|
||
|
@@ -0,0 +1,18 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals for mod and modulo where
|
||
|
+! A is a constant array and P is zero.
|
||
|
+!
|
||
|
+! Compilation errors are expected
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ program promotion_int_real_array_const
|
||
|
+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ end program
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..b78a46054f4
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f
|
||
|
@@ -0,0 +1,18 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec-promotion" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals for mod and modulo where
|
||
|
+! A is a constant array and P is zero.
|
||
|
+!
|
||
|
+! Compilation errors are expected
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ program promotion_int_real_array_const
|
||
|
+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" }
|
||
|
+ end program
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..318ab5db97e
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f
|
||
|
@@ -0,0 +1,18 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec -fno-dec-promotion" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals for mod and modulo where
|
||
|
+! A is a constant array and P is zero.
|
||
|
+!
|
||
|
+! Compilation errors are expected
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ program promotion_int_real_array_const
|
||
|
+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" }
|
||
|
+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" }
|
||
|
+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" }
|
||
|
+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" }
|
||
|
+ end program
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..27eb2582bb2
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f
|
||
|
@@ -0,0 +1,90 @@
|
||
|
+! { dg-do run }
|
||
|
+! { dg-options "-fdec -finit-real=snan" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real_const
|
||
|
+ ! array_nan 4th position value is NAN
|
||
|
+ REAL array_nan(4)
|
||
|
+ DATA array_nan(1)/-4.0/
|
||
|
+ DATA array_nan(2)/3.0/
|
||
|
+ DATA array_nan(3)/-2/
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(4, 3)
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_r = MOD(4.0, 3.0)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 2
|
||
|
+ m_r = MOD(4, 3.0)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(4.0, 3)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+
|
||
|
+ md_i = MODULO(4, 3)
|
||
|
+ if (md_i .ne. 1) STOP 5
|
||
|
+ md_r = MODULO(4.0, 3.0)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+ md_r = MODULO(4, 3.0)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7
|
||
|
+ md_r = MODULO(4.0, 3)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 8
|
||
|
+
|
||
|
+ d_i = DIM(4, 3)
|
||
|
+ if (d_i .ne. 1) STOP 9
|
||
|
+ d_r = DIM(4.0, 3.0)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ d_r = DIM(4.0, 3)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ d_r = DIM(3, 4.0)
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ s_i = SIGN(-4, 3)
|
||
|
+ if (s_i .ne. 4) STOP 13
|
||
|
+ s_r = SIGN(4.0, -3.0)
|
||
|
+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14
|
||
|
+ s_r = SIGN(4.0, -3)
|
||
|
+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15
|
||
|
+ s_r = SIGN(-4, 3.0)
|
||
|
+ if (abs(s_r - 4.0) > 1.0D-6) STOP 16
|
||
|
+
|
||
|
+ mx_i = MAX(-4, -3, 2, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 17
|
||
|
+ mx_r = MAX(-4.0, -3.0, 2.0, 1.0)
|
||
|
+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18
|
||
|
+ mx_r = MAX(-4, -3.0, 2.0, 1)
|
||
|
+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19
|
||
|
+ mx_i = MAXLOC(array_nan, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 20
|
||
|
+
|
||
|
+ mn_i = MIN(-4, -3, 2, 1)
|
||
|
+ if (mn_i .ne. -4) STOP 21
|
||
|
+ mn_r = MIN(-4.0, -3.0, 2.0, 1.0)
|
||
|
+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22
|
||
|
+ mn_r = MIN(-4, -3.0, 2.0, 1)
|
||
|
+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23
|
||
|
+ mn_i = MINLOC(array_nan, 1)
|
||
|
+ if (mn_i .ne. 1) STOP 24
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..bdd017b7280
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f
|
||
|
@@ -0,0 +1,90 @@
|
||
|
+! { dg-do run }
|
||
|
+! { dg-options "-fdec-promotion -finit-real=snan" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real_const
|
||
|
+ ! array_nan 4th position value is NAN
|
||
|
+ REAL array_nan(4)
|
||
|
+ DATA array_nan(1)/-4.0/
|
||
|
+ DATA array_nan(2)/3.0/
|
||
|
+ DATA array_nan(3)/-2/
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(4, 3)
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_r = MOD(4.0, 3.0)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 2
|
||
|
+ m_r = MOD(4, 3.0)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(4.0, 3)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+
|
||
|
+ md_i = MODULO(4, 3)
|
||
|
+ if (md_i .ne. 1) STOP 5
|
||
|
+ md_r = MODULO(4.0, 3.0)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+ md_r = MODULO(4, 3.0)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7
|
||
|
+ md_r = MODULO(4.0, 3)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 8
|
||
|
+
|
||
|
+ d_i = DIM(4, 3)
|
||
|
+ if (d_i .ne. 1) STOP 9
|
||
|
+ d_r = DIM(4.0, 3.0)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ d_r = DIM(4.0, 3)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ d_r = DIM(3, 4.0)
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ s_i = SIGN(-4, 3)
|
||
|
+ if (s_i .ne. 4) STOP 13
|
||
|
+ s_r = SIGN(4.0, -3.0)
|
||
|
+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14
|
||
|
+ s_r = SIGN(4.0, -3)
|
||
|
+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15
|
||
|
+ s_r = SIGN(-4, 3.0)
|
||
|
+ if (abs(s_r - 4.0) > 1.0D-6) STOP 16
|
||
|
+
|
||
|
+ mx_i = MAX(-4, -3, 2, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 17
|
||
|
+ mx_r = MAX(-4.0, -3.0, 2.0, 1.0)
|
||
|
+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18
|
||
|
+ mx_r = MAX(-4, -3.0, 2.0, 1)
|
||
|
+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19
|
||
|
+ mx_i = MAXLOC(array_nan, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 20
|
||
|
+
|
||
|
+ mn_i = MIN(-4, -3, 2, 1)
|
||
|
+ if (mn_i .ne. -4) STOP 21
|
||
|
+ mn_r = MIN(-4.0, -3.0, 2.0, 1.0)
|
||
|
+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22
|
||
|
+ mn_r = MIN(-4, -3.0, 2.0, 1)
|
||
|
+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23
|
||
|
+ mn_i = MINLOC(array_nan, 1)
|
||
|
+ if (mn_i .ne. 1) STOP 24
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..ce90a5667d6
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f
|
||
|
@@ -0,0 +1,92 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec -fno-dec-promotion -finit-real=snan" }
|
||
|
+!
|
||
|
+! Test that there is no promotion between integers and reals in
|
||
|
+! intrinsic operations.
|
||
|
+!
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real_const
|
||
|
+ ! array_nan 4th position value is NAN
|
||
|
+ REAL array_nan(4)
|
||
|
+ DATA array_nan(1)/-4.0/
|
||
|
+ DATA array_nan(2)/3.0/
|
||
|
+ DATA array_nan(3)/-2/
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(4, 3)
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_r = MOD(4.0, 3.0)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 2
|
||
|
+ m_r = MOD(4, 3.0) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(4.0, 3) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+
|
||
|
+ md_i = MODULO(4, 3)
|
||
|
+ if (md_i .ne. 1) STOP 5
|
||
|
+ md_r = MODULO(4.0, 3.0)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+ md_r = MODULO(4, 3.0) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7
|
||
|
+ md_r = MODULO(4.0, 3) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 8
|
||
|
+
|
||
|
+ d_i = DIM(4, 3)
|
||
|
+ if (d_i .ne. 1) STOP 9
|
||
|
+ d_r = DIM(4.0, 3.0)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ d_r = DIM(4.0, 3) ! { dg-error "'x' and 'y' arguments" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ d_r = DIM(3, 4.0) ! { dg-error "'x' and 'y' arguments" }
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ s_i = SIGN(-4, 3)
|
||
|
+ if (s_i .ne. 4) STOP 13
|
||
|
+ s_r = SIGN(4.0, -3.0)
|
||
|
+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14
|
||
|
+ s_r = SIGN(4.0, -3) ! { dg-error "'b' argument" }
|
||
|
+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15
|
||
|
+ s_r = SIGN(-4, 3.0) ! { dg-error "'b' argument" }
|
||
|
+ if (abs(s_r - 4.0) > 1.0D-6) STOP 16
|
||
|
+
|
||
|
+ mx_i = MAX(-4, -3, 2, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 17
|
||
|
+ mx_r = MAX(-4.0, -3.0, 2.0, 1.0)
|
||
|
+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18
|
||
|
+ mx_r = MAX(-4, -3.0, 2.0, 1) ! { dg-error "'a2' argument" }
|
||
|
+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19
|
||
|
+ mx_i = MAXLOC(array_nan, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 20
|
||
|
+
|
||
|
+ mn_i = MIN(-4, -3, 2, 1)
|
||
|
+ if (mn_i .ne. -4) STOP 21
|
||
|
+ mn_r = MIN(-4.0, -3.0, 2.0, 1.0)
|
||
|
+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22
|
||
|
+ mn_r = MIN(-4, -3.0, 2.0, 1) ! { dg-error "'a2' argument" }
|
||
|
+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23
|
||
|
+ mn_i = MINLOC(array_nan, 1)
|
||
|
+ if (mn_i .ne. 1) STOP 24
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..5c2cd931a4b
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f
|
||
|
@@ -0,0 +1,130 @@
|
||
|
+! { dg-do run }
|
||
|
+! { dg-options "-fdec" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ INTEGER a_i/4/
|
||
|
+ INTEGER*4 a2_i/4/
|
||
|
+ INTEGER b_i/3/
|
||
|
+ INTEGER*8 b2_i/3/
|
||
|
+ INTEGER x_i/2/
|
||
|
+ INTEGER y_i/1/
|
||
|
+ REAL a_r/4.0/
|
||
|
+ REAL*4 a2_r/4.0/
|
||
|
+ REAL b_r/3.0/
|
||
|
+ REAL*8 b2_r/3.0/
|
||
|
+ REAL x_r/2.0/
|
||
|
+ REAL y_r/1.0/
|
||
|
+
|
||
|
+ REAL array_nan(4)
|
||
|
+ DATA array_nan(1)/-4.0/
|
||
|
+ DATA array_nan(2)/3.0/
|
||
|
+ DATA array_nan(3)/-2/
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ ! array_nan 4th position value is NAN
|
||
|
+ array_nan(4) = 0/l
|
||
|
+
|
||
|
+ m_i = MOD(a_i, b_i)
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_i, b2_i)
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_r, b_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_r, b2_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_i, b_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_r, b_i)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_i, b_i)
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_i, b2_i)
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_r, b_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_r, b2_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_i, b_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_r, b_i)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_i, b_i)
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_i, b2_i)
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_r, b_r)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_r, b2_r)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_r, b_i)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_i, a_r)
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_i, b_i)
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_i, b2_i)
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_r, -b_r)
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21
|
||
|
+ s_r = SIGN(a2_r, -b2_r)
|
||
|
+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22
|
||
|
+ s_r = SIGN(a_r, -b_i)
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23
|
||
|
+ s_r = SIGN(-a_i, b_r)
|
||
|
+ if (abs(s_r - a_r) > 1.0D-6) STOP 24
|
||
|
+
|
||
|
+ mx_i = MAX(-a_i, -b_i, x_i, y_i)
|
||
|
+ if (mx_i .ne. x_i) STOP 25
|
||
|
+ mx_i = MAX(-a2_i, -b2_i, x_i, y_i)
|
||
|
+ if (mx_i .ne. x_i) STOP 26
|
||
|
+ mx_r = MAX(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27
|
||
|
+ mx_r = MAX(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28
|
||
|
+ mx_r = MAX(-a_i, -b_r, x_r, y_i)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29
|
||
|
+ mx_i = MAXLOC(array_nan, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 30
|
||
|
+
|
||
|
+ mn_i = MIN(-a_i, -b_i, x_i, y_i)
|
||
|
+ if (mn_i .ne. -a_i) STOP 31
|
||
|
+ mn_i = MIN(-a2_i, -b2_i, x_i, y_i)
|
||
|
+ if (mn_i .ne. -a2_i) STOP 32
|
||
|
+ mn_r = MIN(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33
|
||
|
+ mn_r = MIN(-a2_r, -b2_r, x_r, y_r)
|
||
|
+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34
|
||
|
+ mn_r = MIN(-a_i, -b_r, x_r, y_i)
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35
|
||
|
+ mn_i = MINLOC(array_nan, 1)
|
||
|
+ if (mn_i .ne. 1) STOP 36
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..d64d468f7d1
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f
|
||
|
@@ -0,0 +1,130 @@
|
||
|
+! { dg-do run }
|
||
|
+! { dg-options "-fdec-promotion" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ INTEGER a_i/4/
|
||
|
+ INTEGER*4 a2_i/4/
|
||
|
+ INTEGER b_i/3/
|
||
|
+ INTEGER*8 b2_i/3/
|
||
|
+ INTEGER x_i/2/
|
||
|
+ INTEGER y_i/1/
|
||
|
+ REAL a_r/4.0/
|
||
|
+ REAL*4 a2_r/4.0/
|
||
|
+ REAL b_r/3.0/
|
||
|
+ REAL*8 b2_r/3.0/
|
||
|
+ REAL x_r/2.0/
|
||
|
+ REAL y_r/1.0/
|
||
|
+
|
||
|
+ REAL array_nan(4)
|
||
|
+ DATA array_nan(1)/-4.0/
|
||
|
+ DATA array_nan(2)/3.0/
|
||
|
+ DATA array_nan(3)/-2/
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ ! array_nan 4th position value is NAN
|
||
|
+ array_nan(4) = 0/l
|
||
|
+
|
||
|
+ m_i = MOD(a_i, b_i)
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_i, b2_i)
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_r, b_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_r, b2_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_i, b_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_r, b_i)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_i, b_i)
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_i, b2_i)
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_r, b_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_r, b2_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_i, b_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_r, b_i)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_i, b_i)
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_i, b2_i)
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_r, b_r)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_r, b2_r)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_r, b_i)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_i, a_r)
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_i, b_i)
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_i, b2_i)
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_r, -b_r)
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21
|
||
|
+ s_r = SIGN(a2_r, -b2_r)
|
||
|
+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22
|
||
|
+ s_r = SIGN(a_r, -b_i)
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23
|
||
|
+ s_r = SIGN(-a_i, b_r)
|
||
|
+ if (abs(s_r - a_r) > 1.0D-6) STOP 24
|
||
|
+
|
||
|
+ mx_i = MAX(-a_i, -b_i, x_i, y_i)
|
||
|
+ if (mx_i .ne. x_i) STOP 25
|
||
|
+ mx_i = MAX(-a2_i, -b2_i, x_i, y_i)
|
||
|
+ if (mx_i .ne. x_i) STOP 26
|
||
|
+ mx_r = MAX(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27
|
||
|
+ mx_r = MAX(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28
|
||
|
+ mx_r = MAX(-a_i, -b_r, x_r, y_i)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29
|
||
|
+ mx_i = MAXLOC(array_nan, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 30
|
||
|
+
|
||
|
+ mn_i = MIN(-a_i, -b_i, x_i, y_i)
|
||
|
+ if (mn_i .ne. -a_i) STOP 31
|
||
|
+ mn_i = MIN(-a2_i, -b2_i, x_i, y_i)
|
||
|
+ if (mn_i .ne. -a2_i) STOP 32
|
||
|
+ mn_r = MIN(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33
|
||
|
+ mn_r = MIN(-a2_r, -b2_r, x_r, y_r)
|
||
|
+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34
|
||
|
+ mn_r = MIN(-a_i, -b_r, x_r, y_i)
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35
|
||
|
+ mn_i = MINLOC(array_nan, 1)
|
||
|
+ if (mn_i .ne. 1) STOP 36
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..0708b666633
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f
|
||
|
@@ -0,0 +1,130 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec -fno-dec-promotion" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ INTEGER a_i/4/
|
||
|
+ INTEGER*4 a2_i/4/
|
||
|
+ INTEGER b_i/3/
|
||
|
+ INTEGER*8 b2_i/3/
|
||
|
+ INTEGER x_i/2/
|
||
|
+ INTEGER y_i/1/
|
||
|
+ REAL a_r/4.0/
|
||
|
+ REAL*4 a2_r/4.0/
|
||
|
+ REAL b_r/3.0/
|
||
|
+ REAL*8 b2_r/3.0/
|
||
|
+ REAL x_r/2.0/
|
||
|
+ REAL y_r/1.0/
|
||
|
+
|
||
|
+ REAL array_nan(4)
|
||
|
+ DATA array_nan(1)/-4.0/
|
||
|
+ DATA array_nan(2)/3.0/
|
||
|
+ DATA array_nan(3)/-2/
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ ! array_nan 4th position value is NAN
|
||
|
+ array_nan(4) = 0/l
|
||
|
+
|
||
|
+ m_i = MOD(a_i, b_i)
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_i, b2_i)
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_r, b_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_r, b2_r)
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_i, b_r) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_r, b_i) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_i, b_i)
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_i, b2_i)
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_r, b_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_r, b2_r)
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_i, b_r) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_r, b_i) ! { dg-error "'a' and 'p' arguments" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_i, b_i)
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_i, b2_i)
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_r, b_r)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_r, b2_r)
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_r, b_i) ! { dg-error "'x' and 'y' arguments" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_i, a_r) ! { dg-error "'x' and 'y' arguments" }
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_i, b_i)
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_i, b2_i) ! { dg-error "'b' argument" }
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_r, -b_r)
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21
|
||
|
+ s_r = SIGN(a2_r, -b2_r) ! { dg-error "'b' argument" }
|
||
|
+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22
|
||
|
+ s_r = SIGN(a_r, -b_i) ! { dg-error "'b' argument" }
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23
|
||
|
+ s_r = SIGN(-a_i, b_r) ! { dg-error "'b' argument" }
|
||
|
+ if (abs(s_r - a_r) > 1.0D-6) STOP 24
|
||
|
+
|
||
|
+ mx_i = MAX(-a_i, -b_i, x_i, y_i)
|
||
|
+ if (mx_i .ne. x_i) STOP 25
|
||
|
+ mx_i = MAX(-a2_i, -b2_i, x_i, y_i)
|
||
|
+ if (mx_i .ne. x_i) STOP 26
|
||
|
+ mx_r = MAX(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27
|
||
|
+ mx_r = MAX(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28
|
||
|
+ mx_r = MAX(-a_i, -b_r, x_r, y_i) ! { dg-error "'a2' argument" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29
|
||
|
+ mx_i = MAXLOC(array_nan, 1)
|
||
|
+ if (mx_i .ne. 2) STOP 30
|
||
|
+
|
||
|
+ mn_i = MIN(-a_i, -b_i, x_i, y_i)
|
||
|
+ if (mn_i .ne. -a_i) STOP 31
|
||
|
+ mn_i = MIN(-a2_i, -b2_i, x_i, y_i)
|
||
|
+ if (mn_i .ne. -a2_i) STOP 32
|
||
|
+ mn_r = MIN(-a_r, -b_r, x_r, y_r)
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33
|
||
|
+ mn_r = MIN(-a2_r, -b2_r, x_r, y_r)
|
||
|
+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34
|
||
|
+ mn_r = MIN(-a_i, -b_r, x_r, y_i) ! { dg-error "'a2' argument" }
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35
|
||
|
+ mn_i = MINLOC(array_nan, 1)
|
||
|
+ if (mn_i .ne. 1) STOP 36
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..efa4f236410
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f
|
||
|
@@ -0,0 +1,118 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ LOGICAL a_l
|
||
|
+ LOGICAL*4 a2_l
|
||
|
+ LOGICAL b_l
|
||
|
+ LOGICAL*8 b2_l
|
||
|
+ LOGICAL x_l
|
||
|
+ LOGICAL y_l
|
||
|
+ CHARACTER a_c
|
||
|
+ CHARACTER*4 a2_c
|
||
|
+ CHARACTER b_c
|
||
|
+ CHARACTER*8 b2_c
|
||
|
+ CHARACTER x_c
|
||
|
+ CHARACTER y_c
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(a_l, b_l) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_c, b_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_c, b2_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_l, b_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_c, b_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_l, b_l) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_c, b_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_c, b2_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_l, b_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_c, b_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_l, b_l) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_c, b_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_c, b2_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_c, b_l) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_l, a_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_l, b_l) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_c, -b_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" }
|
||
|
+ s_r = SIGN(a2_c, -b2_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" }
|
||
|
+ s_r = SIGN(a_c, -b_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" }
|
||
|
+ s_r = SIGN(-a_l, b_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" }
|
||
|
+
|
||
|
+ mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_l) STOP 25 ! { dg-error "" }
|
||
|
+ mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_l) STOP 26 ! { dg-error "" }
|
||
|
+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" }
|
||
|
+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" }
|
||
|
+ mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" }
|
||
|
+
|
||
|
+ mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" }
|
||
|
+ mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" }
|
||
|
+ mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" }
|
||
|
+ mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" }
|
||
|
+ mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" }
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..d023af5086d
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f
|
||
|
@@ -0,0 +1,118 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec-promotion" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ LOGICAL a_l
|
||
|
+ LOGICAL*4 a2_l
|
||
|
+ LOGICAL b_l
|
||
|
+ LOGICAL*8 b2_l
|
||
|
+ LOGICAL x_l
|
||
|
+ LOGICAL y_l
|
||
|
+ CHARACTER a_c
|
||
|
+ CHARACTER*4 a2_c
|
||
|
+ CHARACTER b_c
|
||
|
+ CHARACTER*8 b2_c
|
||
|
+ CHARACTER x_c
|
||
|
+ CHARACTER y_c
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(a_l, b_l) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_c, b_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_c, b2_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_l, b_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_c, b_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_l, b_l) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_c, b_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_c, b2_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_l, b_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_c, b_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_l, b_l) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_c, b_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_c, b2_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_c, b_l) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_l, a_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_l, b_l) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_l, b2_l) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_c, -b_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" }
|
||
|
+ s_r = SIGN(a2_c, -b2_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" }
|
||
|
+ s_r = SIGN(a_c, -b_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" }
|
||
|
+ s_r = SIGN(-a_l, b_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" }
|
||
|
+
|
||
|
+ mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_l) STOP 25 ! { dg-error "" }
|
||
|
+ mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_l) STOP 26 ! { dg-error "" }
|
||
|
+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" }
|
||
|
+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" }
|
||
|
+ mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" }
|
||
|
+
|
||
|
+ mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" }
|
||
|
+ mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" }
|
||
|
+ mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" }
|
||
|
+ mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" }
|
||
|
+ mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" }
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..00f8fb88f1b
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f
|
||
|
@@ -0,0 +1,118 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ INTEGER a_i/4/
|
||
|
+ INTEGER*4 a2_i/4/
|
||
|
+ CHARACTER b_c
|
||
|
+ CHARACTER*8 b2_c
|
||
|
+ INTEGER x_i/2/
|
||
|
+ CHARACTER y_c
|
||
|
+ REAL a_r/4.0/
|
||
|
+ REAL*4 a2_r/4.0/
|
||
|
+ LOGICAL b_l
|
||
|
+ LOGICAL*8 b2_l
|
||
|
+ REAL x_r/2.0/
|
||
|
+ LOGICAL y_l
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(a_i, b_c) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_r, b_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_r, b2_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_i, b_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_r, b_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_i, b_c) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_r, b_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_r, b2_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_i, b_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_r, b_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_i, b_c) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_r, b_l) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_r, b2_l) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_r, b_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_c, a_r) ! { dg-error "" }
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_i, b_c) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_r, -b_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21
|
||
|
+ s_r = SIGN(a2_r, -b2_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22
|
||
|
+ s_r = SIGN(a_r, -b_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23
|
||
|
+ s_r = SIGN(-a_i, b_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - a_r) > 1.0D-6) STOP 24
|
||
|
+
|
||
|
+ mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_i) STOP 25
|
||
|
+ mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_i) STOP 26
|
||
|
+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27
|
||
|
+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28
|
||
|
+ mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29
|
||
|
+
|
||
|
+ mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a_i) STOP 31
|
||
|
+ mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a2_i) STOP 32
|
||
|
+ mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33
|
||
|
+ mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34
|
||
|
+ mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..1d4150d81c0
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f
|
||
|
@@ -0,0 +1,118 @@
|
||
|
+! { dg-do compile }
|
||
|
+! { dg-options "-fdec-promotion" }
|
||
|
+!
|
||
|
+! Test promotion between integers and reals in intrinsic operations.
|
||
|
+! These operations are: mod, modulo, dim, sign, min, max, minloc and
|
||
|
+! maxloc.
|
||
|
+!
|
||
|
+! Contributed by Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>
|
||
|
+! and Jeff Law <law@redhat.com>
|
||
|
+! Modified by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ PROGRAM promotion_int_real
|
||
|
+ REAL l/0.0/
|
||
|
+ INTEGER a_i/4/
|
||
|
+ INTEGER*4 a2_i/4/
|
||
|
+ CHARACTER b_c
|
||
|
+ CHARACTER*8 b2_c
|
||
|
+ INTEGER x_i/2/
|
||
|
+ CHARACTER y_c
|
||
|
+ REAL a_r/4.0/
|
||
|
+ REAL*4 a2_r/4.0/
|
||
|
+ LOGICAL b_l
|
||
|
+ LOGICAL*8 b2_l
|
||
|
+ REAL x_r/2.0/
|
||
|
+ LOGICAL y_l
|
||
|
+
|
||
|
+ INTEGER m_i/0/
|
||
|
+ REAL m_r/0.0/
|
||
|
+
|
||
|
+ INTEGER md_i/0/
|
||
|
+ REAL md_r/0.0/
|
||
|
+
|
||
|
+ INTEGER d_i/0/
|
||
|
+ REAL d_r/0.0/
|
||
|
+
|
||
|
+ INTEGER s_i/0/
|
||
|
+ REAL s_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mn_i/0/
|
||
|
+ REAL mn_r/0.0/
|
||
|
+
|
||
|
+ INTEGER mx_i/0/
|
||
|
+ REAL mx_r/0.0/
|
||
|
+
|
||
|
+ m_i = MOD(a_i, b_c) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 1
|
||
|
+ m_i = MOD(a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (m_i .ne. 1) STOP 2
|
||
|
+ m_r = MOD(a_r, b_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3
|
||
|
+ m_r = MOD(a2_r, b2_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4
|
||
|
+ m_r = MOD(a_i, b_l) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5
|
||
|
+ m_r = MOD(a_r, b_c) ! { dg-error "" }
|
||
|
+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6
|
||
|
+
|
||
|
+ md_i = MODULO(a_i, b_c) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 7
|
||
|
+ md_i = MODULO(a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (md_i .ne. 1) STOP 8
|
||
|
+ md_r = MODULO(a_r, b_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9
|
||
|
+ md_r = MODULO(a2_r, b2_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10
|
||
|
+ md_r = MODULO(a_i, b_l) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11
|
||
|
+ md_r = MODULO(a_r, b_c) ! { dg-error "" }
|
||
|
+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12
|
||
|
+
|
||
|
+ d_i = DIM(a_i, b_c) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 13
|
||
|
+ d_i = DIM(a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (d_i .ne. 1) STOP 14
|
||
|
+ d_r = DIM(a_r, b_l) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15
|
||
|
+ d_r = DIM(a2_r, b2_l) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16
|
||
|
+ d_r = DIM(a_r, b_c) ! { dg-error "" }
|
||
|
+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17
|
||
|
+ d_r = DIM(b_c, a_r) ! { dg-error "" }
|
||
|
+ if (abs(d_r) > 1.0D-6) STOP 18
|
||
|
+
|
||
|
+ s_i = SIGN(-a_i, b_c) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 19
|
||
|
+ s_i = SIGN(-a2_i, b2_c) ! { dg-error "" }
|
||
|
+ if (s_i .ne. 4) STOP 20
|
||
|
+ s_r = SIGN(a_r, -b_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21
|
||
|
+ s_r = SIGN(a2_r, -b2_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22
|
||
|
+ s_r = SIGN(a_r, -b_c) ! { dg-error "" }
|
||
|
+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23
|
||
|
+ s_r = SIGN(-a_i, b_l) ! { dg-error "" }
|
||
|
+ if (abs(s_r - a_r) > 1.0D-6) STOP 24
|
||
|
+
|
||
|
+ mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_i) STOP 25
|
||
|
+ mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mx_i .ne. x_i) STOP 26
|
||
|
+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27
|
||
|
+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28
|
||
|
+ mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29
|
||
|
+
|
||
|
+ mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a_i) STOP 31
|
||
|
+ mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" }
|
||
|
+ if (mn_i .ne. -a2_i) STOP 32
|
||
|
+ mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33
|
||
|
+ mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34
|
||
|
+ mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" }
|
||
|
+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35
|
||
|
+ END PROGRAM
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..435bf98350c
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f
|
||
|
@@ -0,0 +1,40 @@
|
||
|
+!{ dg-do run }
|
||
|
+!{ dg-options "-fdec" }
|
||
|
+!
|
||
|
+! integer types of a smaller kind than expected should be
|
||
|
+! accepted by type specific intrinsic functions
|
||
|
+!
|
||
|
+! Contributed by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ program test_small_type_promtion
|
||
|
+ implicit none
|
||
|
+ integer(1) :: a = 1
|
||
|
+ integer :: i
|
||
|
+ if (iiabs(-9_1).ne.9) stop 1
|
||
|
+ if (iabs(-9_1).ne.9) stop 2
|
||
|
+ if (iabs(-9_2).ne.9) stop 3
|
||
|
+ if (jiabs(-9_1).ne.9) stop 4
|
||
|
+ if (jiabs(-9_2).ne.9) stop 5
|
||
|
+ if (iishft(1_1, 2).ne.4) stop 6
|
||
|
+ if (jishft(1_1, 2).ne.4) stop 7
|
||
|
+ if (jishft(1_2, 2).ne.4) stop 8
|
||
|
+ if (kishft(1_1, 2).ne.4) stop 9
|
||
|
+ if (kishft(1_2, 2).ne.4) stop 10
|
||
|
+ if (kishft(1_4, 2).ne.4) stop 11
|
||
|
+ if (imod(17_1, 3).ne.2) stop 12
|
||
|
+ if (jmod(17_1, 3).ne.2) stop 13
|
||
|
+ if (jmod(17_2, 3).ne.2) stop 14
|
||
|
+ if (kmod(17_1, 3).ne.2) stop 15
|
||
|
+ if (kmod(17_2, 3).ne.2) stop 16
|
||
|
+ if (kmod(17_4, 3).ne.2) stop 17
|
||
|
+ if (inot(5_1).ne.-6) stop 18
|
||
|
+ if (jnot(5_1).ne.-6) stop 19
|
||
|
+ if (jnot(5_2).ne.-6) stop 20
|
||
|
+ if (knot(5_1).ne.-6) stop 21
|
||
|
+ if (knot(5_2).ne.-6) stop 22
|
||
|
+ if (knot(5_4).ne.-6) stop 23
|
||
|
+ if (isign(-77_1, 1).ne.77) stop 24
|
||
|
+ if (isign(-77_1, -1).ne.-77) stop 25
|
||
|
+ if (isign(-77_2, 1).ne.77) stop 26
|
||
|
+ if (isign(-77_2, -1).ne.-77) stop 27
|
||
|
+ end program
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..7b1697ca665
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f
|
||
|
@@ -0,0 +1,40 @@
|
||
|
+!{ dg-do run }
|
||
|
+!{ dg-options "-fdec-intrinsic-ints -fdec-promotion" }
|
||
|
+!
|
||
|
+! integer types of a smaller kind than expected should be
|
||
|
+! accepted by type specific intrinsic functions
|
||
|
+!
|
||
|
+! Contributed by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ program test_small_type_promtion
|
||
|
+ implicit none
|
||
|
+ integer(1) :: a = 1
|
||
|
+ integer :: i
|
||
|
+ if (iiabs(-9_1).ne.9) stop 1
|
||
|
+ if (iabs(-9_1).ne.9) stop 2
|
||
|
+ if (iabs(-9_2).ne.9) stop 3
|
||
|
+ if (jiabs(-9_1).ne.9) stop 4
|
||
|
+ if (jiabs(-9_2).ne.9) stop 5
|
||
|
+ if (iishft(1_1, 2).ne.4) stop 6
|
||
|
+ if (jishft(1_1, 2).ne.4) stop 7
|
||
|
+ if (jishft(1_2, 2).ne.4) stop 8
|
||
|
+ if (kishft(1_1, 2).ne.4) stop 9
|
||
|
+ if (kishft(1_2, 2).ne.4) stop 10
|
||
|
+ if (kishft(1_4, 2).ne.4) stop 11
|
||
|
+ if (imod(17_1, 3).ne.2) stop 12
|
||
|
+ if (jmod(17_1, 3).ne.2) stop 13
|
||
|
+ if (jmod(17_2, 3).ne.2) stop 14
|
||
|
+ if (kmod(17_1, 3).ne.2) stop 15
|
||
|
+ if (kmod(17_2, 3).ne.2) stop 16
|
||
|
+ if (kmod(17_4, 3).ne.2) stop 17
|
||
|
+ if (inot(5_1).ne.-6) stop 18
|
||
|
+ if (jnot(5_1).ne.-6) stop 19
|
||
|
+ if (jnot(5_2).ne.-6) stop 20
|
||
|
+ if (knot(5_1).ne.-6) stop 21
|
||
|
+ if (knot(5_2).ne.-6) stop 22
|
||
|
+ if (knot(5_4).ne.-6) stop 23
|
||
|
+ if (isign(-77_1, 1).ne.77) stop 24
|
||
|
+ if (isign(-77_1, -1).ne.-77) stop 25
|
||
|
+ if (isign(-77_2, 1).ne.77) stop 26
|
||
|
+ if (isign(-77_2, -1).ne.-77) stop 27
|
||
|
+ end program
|
||
|
diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f
|
||
|
new file mode 100644
|
||
|
index 00000000000..db8dff6c55d
|
||
|
--- /dev/null
|
||
|
+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f
|
||
|
@@ -0,0 +1,39 @@
|
||
|
+!{ dg-do compile }
|
||
|
+!{ dg-options "-fdec -fno-dec-promotion" }
|
||
|
+!
|
||
|
+! integer types of a smaller kind than expected should be
|
||
|
+! accepted by type specific intrinsic functions
|
||
|
+!
|
||
|
+! Contributed by Mark Eggleston <mark.eggleston@codethink.com>
|
||
|
+!
|
||
|
+ program test_small_type_promtion
|
||
|
+ integer(1) :: a = 1
|
||
|
+ integer :: i
|
||
|
+ if (iiabs(-9_1).ne.9) stop 1
|
||
|
+ if (iabs(-9_1).ne.9) stop 2 ! { dg-error "type mismatch in argument" }
|
||
|
+ if (iabs(-9_2).ne.9) stop 3 ! { dg-error "type mismatch in argument" }
|
||
|
+ if (jiabs(-9_1).ne.9) stop 4
|
||
|
+ if (jiabs(-9_2).ne.9) stop 5
|
||
|
+ if (iishft(1_1, 2).ne.4) stop 6
|
||
|
+ if (jishft(1_1, 2).ne.4) stop 7
|
||
|
+ if (jishft(1_2, 2).ne.4) stop 8
|
||
|
+ if (kishft(1_1, 2).ne.4) stop 9
|
||
|
+ if (kishft(1_2, 2).ne.4) stop 10
|
||
|
+ if (kishft(1_4, 2).ne.4) stop 11
|
||
|
+ if (imod(17_1, 3).ne.2) stop 12
|
||
|
+ if (jmod(17_1, 3).ne.2) stop 13
|
||
|
+ if (jmod(17_2, 3).ne.2) stop 14
|
||
|
+ if (kmod(17_1, 3).ne.2) stop 15
|
||
|
+ if (kmod(17_2, 3).ne.2) stop 16
|
||
|
+ if (kmod(17_4, 3).ne.2) stop 17
|
||
|
+ if (inot(5_1).ne.-6) stop 18
|
||
|
+ if (jnot(5_1).ne.-6) stop 19
|
||
|
+ if (jnot(5_2).ne.-6) stop 20
|
||
|
+ if (knot(5_1).ne.-6) stop 21
|
||
|
+ if (knot(5_2).ne.-6) stop 22
|
||
|
+ if (knot(5_4).ne.-6) stop 23
|
||
|
+ if (isign(-77_1, 1).ne.77) stop 24 ! { dg-error "type mismatch in argument" }
|
||
|
+ if (isign(-77_1, -1).ne.-77) stop 25 ! { dg-error "type mismatch in argument" }
|
||
|
+ if (isign(-77_2, 1).ne.77) stop 26 ! { dg-error "type mismatch in argument" }
|
||
|
+ if (isign(-77_2, -1).ne.-77) stop 27 ! { dg-error "type mismatch in argument" }
|
||
|
+ end program
|
||
|
--
|
||
|
2.11.0
|
||
|
|