commit a2ddfaea2bbe8ea26c37c1d31db71c56855e10ce

Author: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>

Date:   Mon Apr 9 15:10:02 2018 +0100

    Add support for type promotion in intrinsic arguments

    This feature is supported by the DEC compiler and can be enabled

    using the -fdec flag.

    Signed-off-by: Ben Brewer <ben.brewer@codethink.co.uk>

    Tests written by: Francisco Redondo Marchena <francisco.marchena@codethink.co.uk>

                      Jeff Law <law@redhat.com>

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c

index fd0b00a..423d2cb 100644

--- a/gcc/fortran/check.c

+++ b/gcc/fortran/check.c

@@ -932,12 +932,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)

+    return check_int_real_promotion (a, p);

+

   if (!int_or_real_check (a, 0))

     return false;

@@ -3140,6 +3168,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)

 {

@@ -3164,7 +3227,10 @@ gfc_check_min_max (gfc_actual_arglist *arg)

       return false;

     }

-  return check_rest (x->ts.type, x->ts.kind, arg);

+  if (flag_dec && x->ts.type != BT_CHARACTER)

+    return check_rest_int_real (arg);

+  else

+    return check_rest (x->ts.type, x->ts.kind, arg);

 }

@@ -4426,6 +4492,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift)

 bool

 gfc_check_sign (gfc_expr *a, gfc_expr *b)

 {

+  if (flag_dec)

+    return check_int_real_promotion (a, b);

+

   if (!int_or_real_check (a, 0))

     return false;

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c

index f15b8f2..0932180 100644

--- a/gcc/fortran/iresolve.c

+++ b/gcc/fortran/iresolve.c

@@ -892,19 +892,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);

@@ -1659,14 +1662,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);

     }

@@ -2050,19 +2056,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);

@@ -2072,19 +2081,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),

@@ -2455,9 +2467,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/simplify.c b/gcc/fortran/simplify.c

index 7603f30..2de9a29 100644

--- a/gcc/fortran/simplify.c

+++ b/gcc/fortran/simplify.c

@@ -2254,39 +2254,78 @@ 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");

@@ -4881,13 +4920,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)

 {

   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:

@@ -5457,7 +5570,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;

@@ -5468,18 +5583,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");

     }

@@ -5487,16 +5602,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");

@@ -5509,7 +5632,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;

@@ -5520,44 +5645,50 @@ 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");

@@ -6976,27 +7107,40 @@ 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)

-	  mpfr_copysign (result->value.real, x->value.real, y->value.real,

-			GFC_RND_MODE);

+	if (flag_sign_zero && y->ts.type == BT_REAL)

+	  mpfr_copysign (result->value.real, x->value.real, y->value.real, 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.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f

new file mode 100644

index 0000000..d77a46e

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f

@@ -0,0 +1,14 @@

+! { 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

+!

+      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_const_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f

new file mode 100644

index 0000000..2784b34

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f

@@ -0,0 +1,86 @@

+! { dg-do compile }

+! { 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.

+!

+      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)