[PATCH/gfortran] Fix rounding in constant folding

[Steve Kargl]

The attached patch fixes a rounding problem in 
nint, anint, and dnint during gfortran's constant
folding.  This patch does not address the problem
noticed by Geert Bosch gfortran's build_round_expr.

Bubblestrapped and regression tested on i386-*-freebsd
and amd64-*-freebsd.

Ok to commit to mainline and 4.0?

2005-04-09  Steven G. Kargl  <kargls@comcast.net>

	* simplify.c (gfc_simplify_anint): Use mpfr_round()
	(gfc_simplify_dnint): ditto.
	(gfc_simplify_nint): ditto.

2005-04-09  Steven G. Kargl  <kargls@comcast.net>

	* gfortran.dg/nint_1.f90: New test.
	* gfortran.dg/anint_1.f90: ditto.

-- 
Steve
-------------- next part --------------
Index: simplify.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/simplify.c,v
retrieving revision 1.21
diff -c -p -r1.21 simplify.c
*** simplify.c	7 Apr 2005 18:26:37 -0000	1.21
--- simplify.c	9 Apr 2005 15:25:58 -0000
*************** gfc_simplify_dint (gfc_expr * e)
*** 409,417 ****
  gfc_expr *
  gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
  {
!   gfc_expr *rtrunc, *result;
!   int kind, cmp;
!   mpfr_t half;
  
    kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
    if (kind == -1)
--- 409,416 ----
  gfc_expr *
  gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
  {
!   gfc_expr *result;
!   int kind;
  
    kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
    if (kind == -1)
*************** gfc_simplify_anint (gfc_expr * e, gfc_ex
*** 422,450 ****
  
    result = gfc_constant_result (e->ts.type, kind, &e->where);
  
!   rtrunc = gfc_copy_expr (e);
! 
!   cmp = mpfr_cmp_ui (e->value.real, 0);
! 
!   gfc_set_model_kind (kind);
!   mpfr_init (half);
!   mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
! 
!   if (cmp > 0)
!     {
!       mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
!       mpfr_trunc (result->value.real, rtrunc->value.real);
!     }
!   else if (cmp < 0)
!     {
!       mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
!       mpfr_trunc (result->value.real, rtrunc->value.real);
!     }
!   else
!     mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
! 
!   gfc_free_expr (rtrunc);
!   mpfr_clear (half);
  
    return range_check (result, "ANINT");
  }
--- 421,427 ----
  
    result = gfc_constant_result (e->ts.type, kind, &e->where);
  
!   mpfr_round (result->value.real, e->value.real);
  
    return range_check (result, "ANINT");
  }
*************** gfc_simplify_anint (gfc_expr * e, gfc_ex
*** 453,491 ****
  gfc_expr *
  gfc_simplify_dnint (gfc_expr * e)
  {
!   gfc_expr *rtrunc, *result;
!   int cmp;
!   mpfr_t half;
  
    if (e->expr_type != EXPR_CONSTANT)
      return NULL;
  
!   result =
!     gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
! 
!   rtrunc = gfc_copy_expr (e);
  
!   cmp = mpfr_cmp_ui (e->value.real, 0);
! 
!   gfc_set_model_kind (gfc_default_double_kind);
!   mpfr_init (half);
!   mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
! 
!   if (cmp > 0)
!     {
!       mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
!       mpfr_trunc (result->value.real, rtrunc->value.real);
!     }
!   else if (cmp < 0)
!     {
!       mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
!       mpfr_trunc (result->value.real, rtrunc->value.real);
!     }
!   else
!     mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
! 
!   gfc_free_expr (rtrunc);
!   mpfr_clear (half);
  
    return range_check (result, "DNINT");
  }
--- 430,443 ----
  gfc_expr *
  gfc_simplify_dnint (gfc_expr * e)
  {
!   gfc_expr *result;
  
    if (e->expr_type != EXPR_CONSTANT)
      return NULL;
  
!   result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
  
!   mpfr_round (result->value.real, e->value.real);
  
    return range_check (result, "DNINT");
  }
*************** gfc_simplify_nearest (gfc_expr * x, gfc_
*** 2378,2386 ****
  static gfc_expr *
  simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
  {
!   gfc_expr *rtrunc, *itrunc, *result;
!   int kind, cmp;
!   mpfr_t half;
  
    kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
    if (kind == -1)
--- 2330,2337 ----
  static gfc_expr *
  simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
  {
!   gfc_expr *itrunc, *result;
!   int kind;
  
    kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
    if (kind == -1)
*************** simplify_nint (const char *name, gfc_exp
*** 2391,2423 ****
  
    result = gfc_constant_result (BT_INTEGER, kind, &e->where);
  
-   rtrunc = gfc_copy_expr (e);
    itrunc = gfc_copy_expr (e);
  
!   cmp = mpfr_cmp_ui (e->value.real, 0);
! 
!   gfc_set_model (e->value.real);
!   mpfr_init (half);
!   mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
! 
!   if (cmp > 0)
!     {
!       mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
!       mpfr_trunc (itrunc->value.real, rtrunc->value.real);
!     }
!   else if (cmp < 0)
!     {
!       mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
!       mpfr_trunc (itrunc->value.real, rtrunc->value.real);
!     }
!   else
!     mpfr_set_ui (itrunc->value.real, 0, GFC_RND_MODE);
  
    gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
  
    gfc_free_expr (itrunc);
-   gfc_free_expr (rtrunc);
-   mpfr_clear (half);
  
    return range_check (result, name);
  }
--- 2342,2354 ----
  
    result = gfc_constant_result (BT_INTEGER, kind, &e->where);
  
    itrunc = gfc_copy_expr (e);
  
!   mpfr_round(itrunc->value.real, e->value.real);
  
    gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
  
    gfc_free_expr (itrunc);
  
    return range_check (result, name);
  }
-------------- next part --------------
program nint_1
  if (nint(8388609.0)  /= 8388609) call abort
  if (nint(0.49999997) /= 0) call abort
end program nint_1
-------------- next part --------------
program anint_1
  print *,anint(8388609.0)
  print *,anint(0.49999997)
  if (int(anint(8388609.0))  /= 8388609) call abort
  if (int(anint(0.49999997)) /= 0) call abort
end program anint_1