2013-07-21 Tobias Burnus <burnus@net-b.de>

        PR fortran/35862
        * libgfortran.h (GFC_FPE_DOWNWARD, GFC_FPE_TONEAREST,
        GFC_FPE_TOWARDZERO, GFC_FPE_UPWARD): New defines.

2013-07-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/35862
        * libgfortran.h (set_fpu_rounding_mode,
        get_fpu_rounding_mode): New prototypes.
        * config/fpu-387.h (set_fpu_rounding_mode,
        get_fpu_rounding_mode): New functions.
        * config/fpu-aix.h (set_fpu_rounding_mode,
        get_fpu_rounding_mode): Ditto.
        * config/fpu-generic.h (set_fpu_rounding_mode,
        get_fpu_rounding_mode): Ditto.
        * config/fpu-glibc.h (set_fpu_rounding_mode,
        get_fpu_rounding_mode): Ditto.
        * config/fpu-sysv.h (set_fpu_rounding_mode,
        get_fpu_rounding_mode): Ditto.
        * configure.ac: Check for fp_rnd and fp_rnd_t.
        * io/io.h (enum unit_round): Use GFC_FPE_* for the value.
        * io/read.c (convert_real): Set FP ronding mode.
        * Makefile.in: Regenerate.
        * aclocal.m4: Regenerate.
        * config.h.in: Regenerate.
        * configure: Regenerate.

2013-07-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/35862
        * gfortran.dg/round_4.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@201093 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 312 insertions, 2 deletions

diff --git a/libgfortran/config/fpu-387.h b/libgfortran/config/fpu-387.h
index 09709b2ea24..72d86f89ea3 100644
--- a/libgfortran/config/fpu-387.h
+++ b/libgfortran/config/fpu-387.h
@@ -88,7 +88,7 @@ has_sse (void)
 #endif
 }
 
-/* i387 -- see linux <fpu_control.h> header file for details.  */
+/* i387 exceptions -- see linux <fpu_control.h> header file for details.  */
 #define _FPU_MASK_IM  0x01
 #define _FPU_MASK_DM  0x02
 #define _FPU_MASK_ZM  0x04
@@ -99,7 +99,18 @@ has_sse (void)
 
 #define _FPU_EX_ALL   0x3f
 
-void set_fpu (void)
+/* i387 rounding modes.  */
+
+#define _FPU_RC_NEAREST 0x0
+#define _FPU_RC_DOWN    0x400
+#define _FPU_RC_UP      0x800
+#define _FPU_RC_ZERO    0xc00
+
+#define _FPU_RC_MASK    0xc00
+
+
+void
+set_fpu (void)
 {
   int excepts = 0;
   unsigned short cw;
@@ -164,3 +175,72 @@ get_fpu_except_flags (void)
 
   return result;
 }
+
+void
+set_fpu_rounding_mode (int round)
+{
+  int round_mode;
+  unsigned short cw;
+
+  switch (round)
+    {
+    case GFC_FPE_TONEAREST:
+      round_mode = _FPU_RC_NEAREST;
+      break;
+    case GFC_FPE_UPWARD:
+      round_mode = _FPU_RC_UP;
+      break;
+    case GFC_FPE_DOWNWARD:
+      round_mode = _FPU_RC_DOWN;
+      break;
+    case GFC_FPE_TOWARDZERO:
+      round_mode = _FPU_RC_ZERO;
+      break;
+    default:
+      return; /* Should be unreachable.  */
+    }
+
+  __asm__ __volatile__ ("fnstcw\t%0" : "=m" (cw));
+
+  cw &= ~FPU_RC_MASK;
+  cw |= round_mode;
+
+  __asm__ __volatile__ ("fldcw\t%0" : : "m" (cw));
+
+  if (has_sse())
+    {
+      unsigned int cw_sse;
+
+      __asm__ __volatile__ ("%vstmxcsr\t%0" : "=m" (cw_sse));
+
+      /* The SSE round control bits are shifted by 3 bits.  */
+      cw_sse &= ~(FPU_RC_MASK << 3);
+      cw_sse |= round_mode << 3;
+
+      __asm__ __volatile__ ("%vldmxcsr\t%0" : : "m" (cw_sse));
+    }
+}
+
+int
+get_fpu_rounding_mode (void)
+{
+  unsigned short cw;
+
+  __asm__ __volatile__ ("fnstcw\t%0" : "=m" (cw));
+
+  cw &= FPU_RC_MASK;
+
+  switch (cw)
+    {
+    case _FPU_RC_NEAREST:
+      return GFC_FPE_TONEAREST;
+    case _FPU_RC_UP:
+      return GFC_FPE_UPWARD;
+    case _FPU_RC_DOWN:
+      return GFC_FPE_DOWNWARD;
+    case _FPU_RC_ZERO:
+      return GFC_FPE_TOWARDZERO;
+    default:
+      return GFC_FPE_INVALID; /* Should be unreachable.  */
+    }
+}
diff --git a/libgfortran/config/fpu-aix.h b/libgfortran/config/fpu-aix.h
index 1ba9d4cfb22..a30d7d0666a 100644
--- a/libgfortran/config/fpu-aix.h
+++ b/libgfortran/config/fpu-aix.h
@@ -116,3 +116,75 @@ get_fpu_except_flags (void)
 
   return result;
 }
+
+
+int
+get_fpu_rounding_mode (void)
+{
+  int rnd_mode;
+
+  rnd_mode = fegetround ();
+
+  switch (rnd_mode)
+    {
+#ifdef FE_TONEAREST
+      case FE_TONEAREST:
+	return GFC_FPE_TONEAREST;
+#endif
+
+#ifdef FE_UPWARD
+      case FE_UPWARD:
+	return GFC_FPE_UPWARD;
+#endif
+
+#ifdef FE_DOWNWARD
+      case FE_DOWNWARD:
+	return GFC_FPE_DOWNWARD;
+#endif
+
+#ifdef FE_TOWARDZERO
+      case FE_TOWARDZERO:
+	return GFC_FPE_TOWARDZERO;
+#endif
+      default:
+	return GFC_FPE_INVALID;
+    }
+}
+
+
+void
+set_fpu_rounding_mode (int mode)
+{
+  int rnd_mode;
+
+  switch (mode)
+    {
+#ifdef FE_TONEAREST
+      case GFC_FPE_TONEAREST:
+	rnd_mode = FE_TONEAREST;
+	break;
+#endif
+
+#ifdef FE_UPWARD
+      case GFC_FPE_UPWARD:
+	rnd_mode = FE_UPWARD;
+	break;
+#endif
+
+#ifdef FE_DOWNWARD
+      case GFC_FPE_DOWNWARD:
+	rnd_mode = FE_DOWNWARD;
+	break;
+#endif
+
+#ifdef FE_TOWARDZERO
+      case GFC_FPE_TOWARDZERO:
+	rnd_mode = FE_TOWARDZERO;
+	break;
+#endif
+      default:
+	return;
+    }
+
+  fesetround (rnd_mode);
+}
diff --git a/libgfortran/config/fpu-generic.h b/libgfortran/config/fpu-generic.h
index 4223f2e27d4..3ad0e832055 100644
--- a/libgfortran/config/fpu-generic.h
+++ b/libgfortran/config/fpu-generic.h
@@ -56,3 +56,16 @@ get_fpu_except_flags (void)
 {
   return 0;
 }
+
+
+int
+get_fpu_rounding_mode (void)
+{   
+  return 0;
+}               
+
+
+void
+set_fpu_rounding_mode (int round __attribute__((unused)))
+{
+}
diff --git a/libgfortran/config/fpu-glibc.h b/libgfortran/config/fpu-glibc.h
index e0d1019b919..66919b8b807 100644
--- a/libgfortran/config/fpu-glibc.h
+++ b/libgfortran/config/fpu-glibc.h
@@ -127,3 +127,75 @@ get_fpu_except_flags (void)
 
   return result;
 }
+
+
+int
+get_fpu_rounding_mode (void)
+{
+  int rnd_mode;
+
+  rnd_mode = fegetround ();
+
+  switch (rnd_mode)
+    {
+#ifdef FE_TONEAREST
+      case FE_TONEAREST:
+	return GFC_FPE_TONEAREST;
+#endif
+
+#ifdef FE_UPWARD
+      case FE_UPWARD:
+	return GFC_FPE_UPWARD;
+#endif
+
+#ifdef FE_DOWNWARD
+      case FE_DOWNWARD:
+	return GFC_FPE_DOWNWARD;
+#endif
+
+#ifdef FE_TOWARDZERO
+      case FE_TOWARDZERO:
+	return GFC_FPE_TOWARDZERO;
+#endif
+      default:
+	return GFC_FPE_INVALID;
+    }
+}
+
+
+void
+set_fpu_rounding_mode (int mode)
+{
+  int rnd_mode;
+
+  switch (mode)
+    {
+#ifdef FE_TONEAREST
+      case GFC_FPE_TONEAREST:
+	rnd_mode = FE_TONEAREST;
+	break;
+#endif
+
+#ifdef FE_UPWARD
+      case GFC_FPE_UPWARD:
+	rnd_mode = FE_UPWARD;
+	break;
+#endif
+
+#ifdef FE_DOWNWARD
+      case GFC_FPE_DOWNWARD:
+	rnd_mode = FE_DOWNWARD;
+	break;
+#endif
+
+#ifdef FE_TOWARDZERO
+      case GFC_FPE_TOWARDZERO:
+	rnd_mode = FE_TOWARDZERO;
+	break;
+#endif
+      default:
+	return;
+    }
+
+  fesetround (rnd_mode);
+}
diff --git a/libgfortran/config/fpu-sysv.h b/libgfortran/config/fpu-sysv.h
index db95e9df093..d7712562a4f 100644
--- a/libgfortran/config/fpu-sysv.h
+++ b/libgfortran/config/fpu-sysv.h
@@ -128,3 +128,76 @@ get_fpu_except_flags (void)
 
   return result;
 }
+
+
+int
+get_fpu_rounding_mode (void)
+{
+  switch (fpgetround ())
+    {
+#ifdef FP_RN
+      case FP_RN:
+	return GFC_FPE_TONEAREST;
+#endif
+
+#ifdef FP_RP
+      case FP_RP:
+	return GFC_FPE_UPWARD;
+#endif
+
+#ifdef FP_RM
+      case FP_RM:
+	return GFC_FPE_DOWNWARD;
+#endif
+
+#ifdef FP_RZ
+      case FP_RZ:
+	return GFC_FPE_TOWARDZERO;
+#endif
+      default:
+	return GFC_FPE_INVALID;
+    }
+}
+
+
+void
+set_fpu_rounding_mode (int mode)
+{
+#if HAVE_FP_RND
+  fp_rnd rnd_mode;
+#elif HAVE_FP_RND_T
+  fp_rnd_t rnd_mode;
+#else
+  choke me
+#endif
+
+  switch (mode)
+    {
+#ifdef FP_RN
+      case GFC_FPE_TONEAREST:
+	rnd_mode = FP_RN;
+        break;
+#endif
+
+#ifdef FP_RP
+      case GFC_FPE_UPWARD:
+	rnd_mode = FP_RP;
+        break;
+#endif
+
+#ifdef FP_RM
+      case GFC_FPE_DOWNWARD:
+	rnd_mode = FP_RM;
+        break;
+#endif
+
+#ifdef FP_RZ
+      case GFC_FPE_TOWARDZERO:
+	rnd_mode = FP_RZ;
+        break;
+#endif
+      default:
+	return;
+    }
+  fpsetround (rnd_mode);
+}