re PR fortran/31202 (Incorrect rounding generated for NINT)

        PR fortran/31202

        * f95-lang.c (gfc_init_builtin_functions): Defin builtins for 
        lround{f,,l} and llround{f,,l}.
        * trans-intrinsic.c (build_fix_expr): Generate calls to the
        {l,}round{f,,l} functions.

        * intrinsics/c99_functions.c (roundl,lroundf,lround,lroundl,
        llroundf,llround,llroundl): New functions.
        * c99_protos.h (roundl,lroundf,lround,lroundl,llroundf,llround,
        llroundl): New prototypes.
        * configure.ac: Check for lroundf, lround, lroundl, llroundf,
        llround and llroundl.
        * configure: Regenerate.
        * Makefile.in: Regenerate.
        * config.h.in: Regenerate.

        * gfortran.dg/nint_2.f90: New test.

From-SVN: r127185

5 files changed, 139 insertions, 22 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c8e4a3c..5d1695b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2007-08-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31202
+	* f95-lang.c (gfc_init_builtin_functions): Defin builtins for 
+	lround{f,,l} and llround{f,,l}.
+	* trans-intrinsic.c (build_fix_expr): Generate calls to the
+	{l,}round{f,,l} functions.
+
 2007-08-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR libfortran/32954
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 0cecac0..425f4d3 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -852,7 +852,7 @@ gfc_init_builtin_functions (void)
   tree func_double_doublep_doublep;
   tree func_longdouble_longdoublep_longdoublep;
   tree ftype, ptype;
-  tree tmp;
+  tree tmp, type;
   tree builtin_types[(int) BT_LAST + 1];
 
   build_builtin_fntypes (mfunc_float, float_type_node);
@@ -942,6 +942,31 @@ gfc_init_builtin_functions (void)
   gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], 
 		      BUILT_IN_FMODF, "fmodf", true);
 
+  /* lround{f,,l} and llround{f,,l} */
+  type = tree_cons (NULL_TREE, float_type_node, void_list_node);
+  tmp = build_function_type (long_integer_type_node, type); 
+  gfc_define_builtin ("__builtin_lroundf", tmp, BUILT_IN_LROUNDF,
+		      "lroundf", true);
+  tmp = build_function_type (long_long_integer_type_node, type); 
+  gfc_define_builtin ("__builtin_llroundf", tmp, BUILT_IN_LLROUNDF,
+		      "llroundf", true);
+
+  type = tree_cons (NULL_TREE, double_type_node, void_list_node);
+  tmp = build_function_type (long_integer_type_node, type); 
+  gfc_define_builtin ("__builtin_lround", tmp, BUILT_IN_LROUND,
+		      "lround", true);
+  tmp = build_function_type (long_long_integer_type_node, type); 
+  gfc_define_builtin ("__builtin_llround", tmp, BUILT_IN_LLROUND,
+		      "llround", true);
+
+  type = tree_cons (NULL_TREE, long_double_type_node, void_list_node);
+  tmp = build_function_type (long_integer_type_node, type); 
+  gfc_define_builtin ("__builtin_lroundl", tmp, BUILT_IN_LROUNDL,
+		      "lroundl", true);
+  tmp = build_function_type (long_long_integer_type_node, type); 
+  gfc_define_builtin ("__builtin_llroundl", tmp, BUILT_IN_LLROUNDL,
+		      "llroundl", true);
+
   /* These are used to implement the ** operator.  */
   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], 
 		      BUILT_IN_POWL, "powl", true);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 39deadb..dc67240 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -25,6 +25,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
+#include "tm.h"
 #include "tree.h"
 #include "ggc.h"
 #include "toplev.h"
@@ -308,34 +309,57 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 }
 
 
-/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
-   NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
+/* Round to nearest integer, away from zero.  */
 
 static tree
-build_round_expr (stmtblock_t * pblock, tree arg, tree type)
+build_round_expr (tree arg, tree restype)
 {
   tree tmp;
-  tree cond;
-  tree neg;
-  tree pos;
   tree argtype;
-  REAL_VALUE_TYPE r;
+  tree fn;
+  bool longlong, convert;
+  int argprec, resprec;
 
   argtype = TREE_TYPE (arg);
-  arg = gfc_evaluate_now (arg, pblock);
+  argprec = TYPE_PRECISION (argtype);
+  resprec = TYPE_PRECISION (restype);
 
-  real_from_string (&r, "0.5");
-  pos = build_real (argtype, r);
-
-  real_from_string (&r, "-0.5");
-  neg = build_real (argtype, r);
+  /* Depending on the type of the result, choose the long int intrinsic
+     (lround family) or long long intrinsic (llround).  We might also
+     need to convert the result afterwards.  */
+  if (resprec <= LONG_TYPE_SIZE)
+    {
+      longlong = false;
+      if (resprec != LONG_TYPE_SIZE)
+	convert = true;
+      else
+	convert = false;
+    }
+  else if (resprec <= LONG_LONG_TYPE_SIZE)
+    {
+      longlong = true;
+      if (resprec != LONG_LONG_TYPE_SIZE)
+	convert = true;
+      else
+	convert = false;
+    }
+  else
+    gcc_unreachable ();
 
-  tmp = gfc_build_const (argtype, integer_zero_node);
-  cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
+  /* Now, depending on the argument type, we choose between intrinsics.  */
+  if (argprec == TYPE_PRECISION (float_type_node))
+    fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
+  else if (argprec == TYPE_PRECISION (double_type_node))
+    fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
+  else if (argprec == TYPE_PRECISION (long_double_type_node))
+    fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
+  else
+    gcc_unreachable ();
 
-  tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
-  tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
-  return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
+  tmp = build_call_expr (fn, 1, arg);
+  if (convert)
+    tmp = fold_convert (restype, tmp);
+  return tmp;
 }
 
 
@@ -358,11 +382,15 @@ build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
       break;
 
     case RND_ROUND:
-      return build_round_expr (pblock, arg, type);
+      return build_round_expr (arg, type);
+      break;
 
-    default:
-      gcc_assert (op == RND_TRUNC);
+    case RND_TRUNC:
       return build1 (FIX_TRUNC_EXPR, type, arg);
+      break;
+
+    default:
+      gcc_unreachable ();
     }
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 892eb9c..e548278 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-08-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31202
+	* gfortran.dg/nint_2.f90: New test.
+
 2007-08-03  Nathan Froyd  <froydnj@codesourcery.com>
 
 	* gcc.dg/tree-ssa/loop-1.c: Skip on powerpc targets if -mlongcall.
diff --git a/gcc/testsuite/gfortran.dg/nint_2.f90 b/gcc/testsuite/gfortran.dg/nint_2.f90
new file mode 100644
index 0000000..b993cb4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/nint_2.f90
@@ -0,0 +1,51 @@
+! Test that NINT gives right results even in corner cases
+!
+! PR 31202
+! http://gcc.gnu.org/ml/fortran/2005-04/msg00139.html
+!
+! { dg-do run }
+  real(kind=8) :: a
+  integer(kind=8) :: i1, i2
+  real :: b
+  integer :: j1, j2
+
+  a = nearest(0.5_8,-1.0_8)
+  i2 = nint(nearest(0.5_8,-1.0_8))
+  i1 = nint(a)
+  if (i1 /= 0 .or. i2 /= 0) call abort
+
+  a = 0.5_8
+  i2 = nint(0.5_8)
+  i1 = nint(a)
+  if (i1 /= 1 .or. i2 /= 1) call abort
+
+  a = nearest(0.5_8,1.0_8)
+  i2 = nint(nearest(0.5_8,1.0_8))
+  i1 = nint(a)
+  if (i1 /= 1 .or. i2 /= 1) call abort
+
+  b = nearest(0.5,-1.0)
+  j2 = nint(nearest(0.5,-1.0))
+  j1 = nint(b)
+  if (j1 /= 0 .or. j2 /= 0) call abort
+
+  b = 0.5
+  j2 = nint(0.5)
+  j1 = nint(b)
+  if (j1 /= 1 .or. j2 /= 1) call abort
+
+  b = nearest(0.5,1.0)
+  j2 = nint(nearest(0.5,1.0))
+  j1 = nint(b)
+  if (j1 /= 1 .or. j2 /= 1) call abort
+
+  a = 4503599627370497.0_8
+  i1 = nint(a,kind=8)
+  i2 = nint(4503599627370497.0_8,kind=8)
+  if (i1 /= i2 .or. i1 /= 4503599627370497_8) call abort
+
+  a = -4503599627370497.0_8
+  i1 = nint(a,kind=8)
+  i2 = nint(-4503599627370497.0_8,kind=8)
+  if (i1 /= i2 .or. i1 /= -4503599627370497_8) call abort
+  end