Re: [gfortran] Fix PR 19032

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Thomas Koenig wrote:
>>I don't know if this works correctly in the case of reals, but I didn't change
>>its current functionality.
> 
> 
> Reals are also broken (see comment #4 for PR 19032).
> 

Updated patch below. This should fix both REALs and INTEGERs, and contains the
old patch which only dealt with INTEGERs. What it does is use FLOOR_MOD_EXPR
(FIX_FLOOR_EXPR) instead of TRUNC_MOD_EXPR (FIX_TRUNC_EXPR) in the case of
INTEGERs (REALs), and do away completely with the special clause which dealt
with MODULO before.

Bubblestrapped and tested, new testcase (essentially the one from the PR)
attached. Ok?

- Tobi

2004-12-20  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/19032
	* trans-intrinsic.c (gfc_conv_intrinsic_mod): Update comment
	in front of function to match the standard.  Correct handling
	of MODULO.

@@ -771,8 +781,8 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, g
   se->expr = fold (build2 (COMPLEX_EXPR, type, real, imag));
 }

-/* Remainder function MOD(A, P) = A - INT(A / P) * P.
-   MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P.  */
+/* Remainder function MOD(A, P) = A - INT(A / P) * P
+                      MODULO(A, P) = A - FLOOR (A / P) * P  */
 /* TODO: MOD(x, 0)  */

 static void
@@ -798,7 +808,10 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
     {
     case BT_INTEGER:
       /* Integer case is easy, we've got a builtin op.  */
-      se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
+      if (modulo)
+       se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
+      else
+       se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
       break;

     case BT_REAL:
@@ -821,7 +834,10 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);

       itype = gfc_get_int_type (expr->ts.kind);
-      tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
+      if (modulo)
+       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
+      else
+       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
       tmp = convert (type, tmp);
       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
       tmp = build2 (MULT_EXPR, type, tmp, arg2);
@@ -832,22 +848,6 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc
     default:
       gcc_unreachable ();
     }
-
-  if (modulo)
-    {
-     zero = gfc_build_const (type, integer_zero_node);
-     /* Build !(A > 0 .xor. P > 0).  */
-     test = build2 (GT_EXPR, boolean_type_node, arg, zero);
-     test2 = build2 (GT_EXPR, boolean_type_node, arg2, zero);
-     test = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
-     test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test);
-     /* Build (A == 0) .or. !(A > 0 .xor. P > 0).  */
-     test2 = build2 (EQ_EXPR, boolean_type_node, arg, zero);
-     test = build2 (TRUTH_OR_EXPR, boolean_type_node, test, test2);
-
-     se->expr = build3 (COND_EXPR, type, test, se->expr,
-                       build2 (PLUS_EXPR, type, se->expr, arg2));
-    }
 }

 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */

! { dg-do run }
! testcase from PR 19032 adapted for testsuite
! Our implementation of modulo was wrong for P = 1 and P = -1,
! both in the real and the integer case
program main
  integer, parameter :: n=16
  real, dimension(n) :: ar, br, modulo_result, floor_result
  integer, dimension(n) :: ai, bi , imodulo_result, ifloor_result

  ai(1:4) = 5
  ai(5:8) = -5
  ai(9:12) = 1
  ai(13:16) = -1
  bi(1:4) = (/ 3,-3, 1, -1/)
  bi(5:8) = bi(1:4)
  bi(9:12) = bi(1:4)
  bi(13:16) = bi(1:4)
  ar = ai
  br = bi
  modulo_result = modulo(ar,br)
  imodulo_result = modulo(ai,bi)
  floor_result = ar-floor(ar/br)*br
  ifloor_result = nint(real(ai-floor(real(ai)/real(bi))*bi))

  do i=1,n
     if (modulo_result(i) /= floor_result(i) ) then
!        print "(A,4F5.0)" ,"real case failed: ", &
!             ar(i),br(i), modulo_result(i), floor_result(i)
        call abort()
    end if
    if (imodulo_result(i) /= ifloor_result(i)) then
!       print "(A,4I5)", "int case failed: ", &
!            ai(i), bi(i), imodulo_result(i), ifloor_result(i)
       call abort ()
     end if
  end do
end program main