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" }

+!