From 79bc3c8c15122dd929703f5ca7e468ffd46c3c3e Mon Sep 17 00:00:00 2001

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

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

Subject: [PATCH 12/16] 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 

Jeff Law <law@redhat.com>

Re-worked by Mark Eggleston <mark.eggleston@codethink.com>

---

 gcc/fortran/check.c                                |  71 +++++-

 gcc/fortran/intrinsic.c                            |   5 +

 gcc/fortran/iresolve.c                             |  91 ++++---

 gcc/fortran/lang.opt                               |   4 +

 gcc/fortran/options.c                              |   1 +

 gcc/fortran/simplify.c                             | 266 ++++++++++++++++-----

 ...ec_intrinsic_int_real_array_const_promotion_1.f |  18 ++

 ...ec_intrinsic_int_real_array_const_promotion_2.f |  18 ++

 ...ec_intrinsic_int_real_array_const_promotion_3.f |  18 ++

 .../dec_intrinsic_int_real_const_promotion_1.f     |  90 +++++++

 .../dec_intrinsic_int_real_const_promotion_2.f     |  90 +++++++

 .../dec_intrinsic_int_real_const_promotion_3.f     |  92 +++++++

 .../dec_intrinsic_int_real_promotion_1.f           | 130 ++++++++++

 .../dec_intrinsic_int_real_promotion_2.f           | 130 ++++++++++

 .../dec_intrinsic_int_real_promotion_3.f           | 130 ++++++++++

 .../dec_intrinsic_int_real_promotion_4.f           | 118 +++++++++

 .../dec_intrinsic_int_real_promotion_5.f           | 118 +++++++++

 .../dec_intrinsic_int_real_promotion_6.f           | 118 +++++++++

 .../dec_intrinsic_int_real_promotion_7.f           | 118 +++++++++

 gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f   |  40 ++++

 gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f   |  40 ++++

 gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f   |  40 ++++

 22 files changed, 1655 insertions(+), 91 deletions(-)

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f

 create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f

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

index 0ba4d0a031f..89416ba368d 100644

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

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

@@ -947,12 +947,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;

@@ -3126,6 +3154,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)

 {

@@ -3150,7 +3213,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);

 }

@@ -4488,6 +4554,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 6d47ae3105f..a4b23bc244a 100644

--- a/gcc/fortran/intrinsic.c

+++ b/gcc/fortran/intrinsic.c

@@ -4329,6 +4329,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 53338dda0a7..92d50c3deb9 100644

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

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

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

@@ -1669,14 +1672,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);

     }

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

@@ -2191,19 +2200,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),

@@ -2578,9 +2590,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 fa2851ae837..2a8f5f661a8 100644

--- a/gcc/fortran/lang.opt

+++ b/gcc/fortran/lang.opt

@@ -490,6 +490,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 7b04a681f7b..7a2583a2076 100644

--- a/gcc/fortran/options.c

+++ b/gcc/fortran/options.c

@@ -83,6 +83,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 7aff256c6b3..cb5f93e293d 100644

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

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

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

@@ -4886,13 +4926,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)

 {

   int ret;

+  mpfr_t *arp;

+  mpfr_t *erp;

+  mpfr_t ar;

+  mpfr_t er;

+

+  if (arg->ts.type != extremum->ts.type)

+    {

+      if (arg->ts.type == BT_REAL)

+	{

+	  arp = &arg->value.real;

+	}

+      else

+	{

+	  mpfr_init2 (ar, (arg->ts.kind * 8));

+	  mpfr_set_z (ar, arg->value.integer, GFC_RND_MODE);

+	  arp = &ar;

+	}

+

+      if (extremum->ts.type == BT_REAL)

+	{

+	  erp = &extremum->value.real;

+	}

+      else

+	{

+	  mpfr_init2 (er, (extremum->ts.kind * 8));

+	  mpfr_set_z (er, extremum->value.integer, GFC_RND_MODE);

+	  erp = &er;

+	}

+

+      if (mpfr_nan_p (*erp))

+	{

+	  ret = 1;

+	  extremum->ts.type = arg->ts.type;

+	  extremum->ts.kind = arg->ts.kind;

+	  if (arg->ts.type == BT_INTEGER)

+	    {

+	      mpz_init2 (extremum->value.integer, (arg->ts.kind * 8));

+	      mpz_set (extremum->value.integer, arg->value.integer);

+	    }

+	  else

+	    {

+	      mpfr_init2 (extremum->value.real, (arg->ts.kind * 8));

+	      mpfr_set (extremum->value.real, *arp, GFC_RND_MODE);

+	    }

+	}

+      else if (mpfr_nan_p (*arp))

+	ret = -1;

+      else

+	{

+	  ret = mpfr_cmp (*arp, *erp) * sign;

+	  if (ret > 0)

+	    {

+	      extremum->ts.type = arg->ts.type;

+	      extremum->ts.kind = arg->ts.kind;

+	      if (arg->ts.type == BT_INTEGER)

+		{

+		  mpz_init2 (extremum->value.integer, (arg->ts.kind * 8));

+		  mpz_set (extremum->value.integer, arg->value.integer);

+		}

+	      else

+		{

+		  mpfr_init2 (extremum->value.real, (arg->ts.kind * 8));

+		  mpfr_set (extremum->value.real, *arp, GFC_RND_MODE);

+		}

+	    }

+	}

+

+      return ret;

+    }

+

   switch (arg->ts.type)

     {

       case BT_INTEGER:

 	ret = mpz_cmp (arg->value.integer,

 		       extremum->value.integer) * sign;

 	if (ret > 0)

-	  mpz_set (extremum->value.integer, arg->value.integer);

+	  {

+	    if (arg->ts.kind > extremum->ts.kind)

+	      extremum->ts.kind = arg->ts.kind;

+	    mpz_set (extremum->value.integer, arg->value.integer);

+	  }

 	break;

       case BT_REAL:

@@ -5841,7 +5955,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;

@@ -5852,18 +5968,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");

     }

@@ -5871,16 +5987,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");

@@ -5893,7 +6017,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;

@@ -5904,44 +6030,52 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)

 	if (mpz_cmp_ui (p->value.integer, 0) == 0)

 	  {

 	    gfc_error ("Argument %qs of MODULO at %L shall not be zero",

-			"P", &p->where);

+	               "P", &p->where);

 	    return &gfc_bad_expr;

 	  }

-	break;

+      break;

       case BT_REAL:

 	if (mpfr_cmp_ui (p->value.real, 0) == 0)

 	  {

 	    gfc_error ("Argument %qs of MODULO at %L shall not be zero",

-			"P", &p->where);

+	               "P", &p->where);

 	    return &gfc_bad_expr;

-	  }

-	break;

+	   }

+      break;

       default:

 	gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");

     }

+  if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER)

+    {

+      gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");

+      return NULL;

+    }

+

   if (a->expr_type != EXPR_CONSTANT)

     return NULL;

   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;

-  result = gfc_get_constant_expr (a->ts.type, kind, &a->where);

-  if (a->ts.type == BT_INTEGER)

-	mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);

-  else

+  if (simplify_int_real_promotion2 (a, p, &ar, &pr))

     {

+      result = gfc_get_constant_expr (BT_REAL, kind, &a->where);

       gfc_set_model_kind (kind);

-      mpfr_fmod (result->value.real, a->value.real, p->value.real,

-                 GFC_RND_MODE);

+      mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE);

       if (mpfr_cmp_ui (result->value.real, 0) != 0)

-        {

-          if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))

-            mpfr_add (result->value.real, result->value.real, p->value.real,

-                      GFC_RND_MODE);

-	    }

-	  else

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

-                       p->value.real, GFC_RND_MODE);

+	{

+	  if (mpfr_signbit (ar) != mpfr_signbit (pr))

+	    mpfr_add (result->value.real, result->value.real, pr,

+		      GFC_RND_MODE);

+	}

+      else

+	mpfr_copysign (result->value.real, result->value.real, pr,

+		       GFC_RND_MODE);

+    }

+  else

+    {

+      result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where);

+      mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);

     }

   return range_check (result, "MODULO");

@@ -7442,27 +7576,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");