rpms/gcc
7
0
Fork 0
Code Issues Pull Requests Releases Activity
90966a8bb5
gcc/gcc11-fortran-fdec-promotion.patch
DistroBaker 196b8d7507 Merged update from upstream sources 
This is an automated DistroBaker update from upstream sources.
If you do not know what this is about or would like to opt out,
contact the OSCI team.

Source: https://src.fedoraproject.org/rpms/gcc.git#7ddd78661a654eebcc2ef9dbc991fafac95e7ed6
2021-03-11 20:25:53 +00:00

2094 lines
72 KiB
Diff
Raw Blame History

From 7a27318818e359a277f2fa5f7dc3932d0fb950f5 Mon Sep 17 00:00:00 2001
From: Mark Eggleston <markeggleston@gcc.gnu.org>
Date: Fri, 22 Jan 2021 14:58:07 +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 | 240 ++++++++++++++----
...trinsic_int_real_array_const_promotion_1.f | 18 ++
...trinsic_int_real_array_const_promotion_2.f | 18 ++
...trinsic_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 +++++++++
.../gfortran.dg/dec_kind_promotion-1.f | 40 +++
.../gfortran.dg/dec_kind_promotion-2.f | 40 +++
.../gfortran.dg/dec_kind_promotion-3.f | 39 +++
22 files changed, 1639 insertions(+), 80 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 623c1cc470e..e20a834a860 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1396,12 +1396,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;
@@ -3724,6 +3752,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)
{
@@ -3748,7 +3811,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);
}
@@ -5121,6 +5187,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 e68eff8bdbb..81b3a24c2be 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4467,6 +4467,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 e17fe45f080..b9cdaff2499 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);
@@ -1606,14 +1609,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);
}
@@ -2106,19 +2112,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);
@@ -2128,19 +2137,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),
@@ -2515,9 +2527,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 d886c2f33ed..4ca2f93f2df 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -505,6 +505,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 a946c86790a..15079c7e95a 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 9900572424f..3419e06fec2 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2333,39 +2333,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");
@@ -4953,6 +4993,76 @@ 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:
@@ -5912,7 +6022,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;
@@ -5942,16 +6054,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");
@@ -5964,7 +6084,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;
@@ -5991,28 +6113,36 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
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");
@@ -7578,27 +7708,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.27.0
Reference in New Issue View Git Blame Copy Permalink