simplify.c (gfc_simplify_modulo): Re-arrange code to test whether 'P' is zero and...

2018-09-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	* simplify.c (gfc_simplify_modulo): Re-arrange code to test whether
	'P' is zero and issue an error if it is.
	* gfortran.dg/modulo_check: New test.

From-SVN: r264070

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c386a649583f973b8d5d42478aa0b90770f81f4c..7cfb94ee1152ac9d5061cfd58d67d40e46dd1bb1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2018-09-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       * simplify.c (gfc_simplify_modulo): Re-arrange code to test whether
+       'P' is zero and issue an error if it is.
+
 2018-08-31  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/86328

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 41997367cf91dcecc073958ee32c6ca7a4e25808..d35bbbaaa1b3d35bd38822c985fa455f25d08669 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -5525,54 +5525,57 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
   gfc_expr *result;
   int kind;
 
-  if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
+  /* First check p.  */
+  if (p->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);
-
-  switch (a->ts.type)
+  /* p shall not be 0.  */
+  switch (p->ts.type)
     {
       case BT_INTEGER:
        if (mpz_cmp_ui (p->value.integer, 0) == 0)
          {
-           /* Result is processor-dependent. This processor just opts
-             to not handle it at all.  */
-           gfc_error ("Second argument of MODULO at %L is zero", &a->where);
-           gfc_free_expr (result);
+           gfc_error ("Argument %qs of MODULO at %L shall not be zero",
+                       "P", &p->where);
            return &gfc_bad_expr;
          }
-       mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
-
        break;
-
       case BT_REAL:
        if (mpfr_cmp_ui (p->value.real, 0) == 0)
          {
-           /* Result is processor-dependent.  */
-           gfc_error ("Second argument of MODULO at %L is zero", &p->where);
-           gfc_free_expr (result);
+           gfc_error ("Argument %qs of MODULO at %L shall not be zero",
+                       "P", &p->where);
            return &gfc_bad_expr;
          }
-
-       gfc_set_model_kind (kind);
-       mpfr_fmod (result->value.real, a->value.real, p->value.real,
-                  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);
        break;
-
       default:
        gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
     }
 
+  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
+    {
+      gfc_set_model_kind (kind);
+      mpfr_fmod (result->value.real, a->value.real, p->value.real,
+                 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);
+    }
+
   return range_check (result, "MODULO");
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9828b4b94dfe80d0ee015f906de81fcf3a703e88..436b4ab854488e93fb9b264fce9928ea3155ea60 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-09-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       * gfortran.dg/modulo_check: New test.
+
 2018-09-03  Richard Biener  <rguenther@suse.de>
 
        PR tree-optimization/87177

diff --git a/gcc/testsuite/gfortran.dg/modulo_check.f90 b/gcc/testsuite/gfortran.dg/modulo_check.f90
new file mode 100644 (file)
index 0000000..8819a2f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/modulo_check.f90
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! Test checks on modulo with p == 0
+program p
+   logical :: a(2) = (modulo([2,3],0) == 0)     ! { dg-error "shall not be zero" }
+   integer :: b = count(modulo([2,3],0) == 0)   ! { dg-error "shall not be zero" }
+   integer :: c = all(modulo([2,3],0) == 0)     ! { dg-error "shall not be zero" }
+   integer :: d = any(modulo([2,3],0) == 0)     ! { dg-error "shall not be zero" }
+end program