Merge GCC 4.8.3

Change-Id: I0abe59f7705b3eccc6b2f123af75b2e30917696a

8 files changed, 225 insertions, 84 deletions

diff --git a/gcc-4.8/libgfortran/ChangeLog b/gcc-4.8/libgfortran/ChangeLog
index cd7a210e5..1aaf6845c 100644
--- a/gcc-4.8/libgfortran/ChangeLog
+++ b/gcc-4.8/libgfortran/ChangeLog
@@ -1,3 +1,79 @@
+2014-05-22  Release Manager
+
+	* GCC 4.8.3 released.
+
+2014-05-03  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	Backport from 4.9
+	PR libfortran/56919
+	* intrinsics/system_clock.c (GF_CLOCK_MONOTONIC): Check
+	_POSIX_MONOTONIC_CLOCK as well.
+
+2014-04-12  Jerry DeLisle  <jvdelisle@gcc.gnu>
+
+	Backport from mainline
+	PR libfortran/60810
+	* io/unit.c (is_trim_ok): If internal unit is array, do not trim.
+
+2014-04-04  Bill Schmidt  <wschmidt@linux.vnet.ibm.com>
+
+	Backport from mainline
+	2013-11-15  Ulrich Weigand  <Ulrich.Weigand@de.ibm.com>
+	* configure: Regenerate.
+
+2014-03-15  Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+	Backport from mainline
+	PR libgfortran/60128
+	* io/write_float.def (output_float): Remove unused variable
+	nzero_real. Replace a double space with a single one.
+	(determine_en_precision): Fix wrong handling of the EN format.
+
+2014-03-15  Jerry DeLisle  <jvdelisle@gcc.gnu>
+
+	Backport from mainline
+	PR libfortran/58324
+	PR libfortran/38199
+	* io/list_read.c (finish_list_read): Read one character to check
+	for the end of the file.  If it is the end, then issue the file
+	end error message.  If not, use eat_line to reach the end
+	without giving error.  The next attempt to read will then
+	issue the error as described above.
+	* io/read.c (read_decimal): Quickly skip spaces to avoid calls
+	to next_char.
+	* io/unit.c (is_trim_ok): New helper function to check various
+	conditions to see if its OK to trim the internal unit string.
+	(get_internal_unit): Use LEN_TRIM to shorten selected internal
+	unit strings for optimizing READ. Enable this optimization for
+	formatted READ.
+
+2014-02-21  Jerry DeLisle  <jvdelisle@gcc.gnu>
+	    Dominique d'Humieres  <dominiq@lps.ens.fr>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	Backport from mainline
+	PR libfortran/59700
+	PR libfortran/59764
+	* io/io.h (struct st_parameter_dt): Assign expanded_read flag to
+	unused bit. Define new variable line_buffer_pos.
+	* io/list_read.c (free_saved, next_char, l_push_char,
+	read_logical, read_real): Replace use of item_count with
+	line_buffer_pos for line_buffer look ahead.
+	(read_logical, read_integer, parse_real, read_real, check_type):
+	Adjust location of free_line to after generating error messages
+	to retain the correct item count for the message. 
+
+2014-02-15  Jerry DeLisle  <jvdelisle@gcc.gnu>
+	    Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+	Backport from mainline
+	PR libfortran/59771
+	PR libfortran/59774
+	PR libfortran/59836
+	* io/write_float.def (output_float): Fix wrong handling of the
+	Fw.0 format.
+	(output_float_FMT_G_): Fixes rounding issues with -m32.
+
 2013-10-16  Release Manager
 
 	* GCC 4.8.2 released.
diff --git a/gcc-4.8/libgfortran/configure b/gcc-4.8/libgfortran/configure
index 8385e9684..ee99e6c89 100755
--- a/gcc-4.8/libgfortran/configure
+++ b/gcc-4.8/libgfortran/configure
@@ -8062,7 +8062,7 @@ ia64-*-hpux*)
   rm -rf conftest*
   ;;
 
-x86_64-*kfreebsd*-gnu|x86_64-*linux*|ppc*-*linux*|powerpc*-*linux*| \
+x86_64-*kfreebsd*-gnu|x86_64-*linux*|powerpc*-*linux*| \
 s390*-*linux*|s390*-*tpf*|sparc*-*linux*)
   # Find out which ABI we are using.
   echo 'int i;' > conftest.$ac_ext
@@ -8087,7 +8087,10 @@ s390*-*linux*|s390*-*tpf*|sparc*-*linux*)
 		;;
 	    esac
 	    ;;
-	  ppc64-*linux*|powerpc64-*linux*)
+	  powerpc64le-*linux*)
+	    LD="${LD-ld} -m elf32lppclinux"
+	    ;;
+	  powerpc64-*linux*)
 	    LD="${LD-ld} -m elf32ppclinux"
 	    ;;
 	  s390x-*linux*)
@@ -8106,7 +8109,10 @@ s390*-*linux*|s390*-*tpf*|sparc*-*linux*)
 	  x86_64-*linux*)
 	    LD="${LD-ld} -m elf_x86_64"
 	    ;;
-	  ppc*-*linux*|powerpc*-*linux*)
+	  powerpcle-*linux*)
+	    LD="${LD-ld} -m elf64lppc"
+	    ;;
+	  powerpc-*linux*)
 	    LD="${LD-ld} -m elf64ppc"
 	    ;;
 	  s390*-*linux*|s390*-*tpf*)
@@ -12333,7 +12339,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 12336 "configure"
+#line 12342 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -12439,7 +12445,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 12442 "configure"
+#line 12448 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
diff --git a/gcc-4.8/libgfortran/intrinsics/system_clock.c b/gcc-4.8/libgfortran/intrinsics/system_clock.c
index 87a87e22f..63ea393f6 100644
--- a/gcc-4.8/libgfortran/intrinsics/system_clock.c
+++ b/gcc-4.8/libgfortran/intrinsics/system_clock.c
@@ -32,7 +32,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 /* POSIX states that CLOCK_REALTIME must be present if clock_gettime
    is available, others are optional.  */
 #if defined(HAVE_CLOCK_GETTIME) || defined(HAVE_CLOCK_GETTIME_LIBRT)
-#ifdef CLOCK_MONOTONIC
+#if defined(CLOCK_MONOTONIC) && defined(_POSIX_MONOTONIC_CLOCK) \
+  && _POSIX_MONOTONIC_CLOCK >= 0
 #define GF_CLOCK_MONOTONIC CLOCK_MONOTONIC
 #else
 #define GF_CLOCK_MONOTONIC CLOCK_REALTIME
diff --git a/gcc-4.8/libgfortran/io/io.h b/gcc-4.8/libgfortran/io/io.h
index 8ea932667..10f09855f 100644
--- a/gcc-4.8/libgfortran/io/io.h
+++ b/gcc-4.8/libgfortran/io/io.h
@@ -424,7 +424,10 @@ typedef struct st_parameter_dt
 	  unsigned g0_no_blanks : 1;
 	  /* Used to signal use of free_format_data.  */
 	  unsigned format_not_saved : 1;
-	  /* 14 unused bits.  */
+	  /* A flag used to identify when a non-standard expanded namelist read
+	     has occurred.  */
+	  unsigned expanded_read : 1;
+	  /* 13 unused bits.  */
 
 	  /* Used for ungetc() style functionality. Possible values
 	     are an unsigned char, EOF, or EOF - 1 used to mark the
@@ -441,9 +444,8 @@ typedef struct st_parameter_dt
 	  char *line_buffer;
 	  struct format_data *fmt;
 	  namelist_info *ionml;
-	  /* A flag used to identify when a non-standard expanded namelist read
-	     has occurred.  */
-	  int expanded_read;
+	  /* Current position within the look-ahead line buffer.  */
+	  int line_buffer_pos;
 	  /* Storage area for values except for strings.  Must be
 	     large enough to hold a complex value (two reals) of the
 	     largest kind.  */
diff --git a/gcc-4.8/libgfortran/io/list_read.c b/gcc-4.8/libgfortran/io/list_read.c
index 60f4549cd..43f606085 100644
--- a/gcc-4.8/libgfortran/io/list_read.c
+++ b/gcc-4.8/libgfortran/io/list_read.c
@@ -118,7 +118,7 @@ free_saved (st_parameter_dt *dtp)
 static void
 free_line (st_parameter_dt *dtp)
 {
-  dtp->u.p.item_count = 0;
+  dtp->u.p.line_buffer_pos = 0;
   dtp->u.p.line_buffer_enabled = 0;
 
   if (dtp->u.p.line_buffer == NULL)
@@ -150,15 +150,15 @@ next_char (st_parameter_dt *dtp)
     {
       dtp->u.p.at_eol = 0;
 
-      c = dtp->u.p.line_buffer[dtp->u.p.item_count];
-      if (c != '\0' && dtp->u.p.item_count < 64)
+      c = dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos];
+      if (c != '\0' && dtp->u.p.line_buffer_pos < 64)
 	{
-	  dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
-	  dtp->u.p.item_count++;
+	  dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos] = '\0';
+	  dtp->u.p.line_buffer_pos++;
 	  goto done;
 	}
 
-      dtp->u.p.item_count = 0;
+      dtp->u.p.line_buffer_pos = 0;
       dtp->u.p.line_buffer_enabled = 0;
     }    
 
@@ -640,7 +640,7 @@ l_push_char (st_parameter_dt *dtp, char c)
   if (dtp->u.p.line_buffer == NULL)
     dtp->u.p.line_buffer = xcalloc (SCRATCH_SIZE, 1);
 
-  dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
+  dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos++] = c;
 }
 
 
@@ -750,7 +750,7 @@ read_logical (st_parameter_dt *dtp, int length)
 	{
 	  dtp->u.p.nml_read_error = 1;
 	  dtp->u.p.line_buffer_enabled = 1;
-	  dtp->u.p.item_count = 0;
+	  dtp->u.p.line_buffer_pos = 0;
 	  return;
 	}
       
@@ -758,14 +758,17 @@ read_logical (st_parameter_dt *dtp, int length)
 
  bad_logical:
 
-  free_line (dtp);
-
   if (nml_bad_return (dtp, c))
+    {
+      free_line (dtp);
     return;
+    }
+
 
   free_saved (dtp);
   if (c == EOF)
     {
+      free_line (dtp);
       hit_eof (dtp);
       return;
     }
@@ -773,6 +776,7 @@ read_logical (st_parameter_dt *dtp, int length)
     eat_line (dtp);
   snprintf (message, MSGLEN, "Bad logical value while reading item %d",
 	      dtp->u.p.item_count);
+  free_line (dtp);
   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
   return;
 
@@ -913,9 +917,9 @@ read_integer (st_parameter_dt *dtp, int length)
   else if (c != '\n')
     eat_line (dtp);
 
-  free_line (dtp);
   snprintf (message, MSGLEN, "Bad integer for item %d in list input",
 	      dtp->u.p.item_count);
+  free_line (dtp);
   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 
   return;
@@ -1298,9 +1302,9 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
   else if (c != '\n')
     eat_line (dtp);
 
-  free_line (dtp);
   snprintf (message, MSGLEN, "Bad floating point number for item %d",
 	      dtp->u.p.item_count);
+  free_line (dtp);
   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 
   return 1;
@@ -1406,9 +1410,9 @@ eol_4:
   else if (c != '\n')   
     eat_line (dtp);
 
-  free_line (dtp);
   snprintf (message, MSGLEN, "Bad complex value in item %d of list input",
 	      dtp->u.p.item_count);
+  free_line (dtp);
   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 }
 
@@ -1770,7 +1774,7 @@ read_real (st_parameter_dt *dtp, void * dest, int length)
     {
       dtp->u.p.nml_read_error = 1;
       dtp->u.p.line_buffer_enabled = 1;
-      dtp->u.p.item_count = 0;
+      dtp->u.p.line_buffer_pos = 0;
       return;
     }
 
@@ -1789,9 +1793,9 @@ read_real (st_parameter_dt *dtp, void * dest, int length)
   else if (c != '\n')
     eat_line (dtp);
 
-  free_line (dtp);
   snprintf (message, MSGLEN, "Bad real number in item %d of list input",
 	      dtp->u.p.item_count);
+  free_line (dtp);
   generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
 }
 
@@ -1806,11 +1810,10 @@ check_type (st_parameter_dt *dtp, bt type, int len)
 
   if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
     {
-      free_line (dtp);
       snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d",
 		  type_name (dtp->u.p.saved_type), type_name (type),
 		  dtp->u.p.item_count);
-
+      free_line (dtp);
       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
       return 1;
     }
@@ -1820,12 +1823,12 @@ check_type (st_parameter_dt *dtp, bt type, int len)
 
   if (dtp->u.p.saved_length != len)
     {
-      free_line (dtp);
       snprintf (message, MSGLEN,
 		  "Read kind %d %s where kind %d is required for item %d",
 		  dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
 		  dtp->u.p.item_count);
       generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+      free_line (dtp);
       return 1;
     }
 
@@ -2031,8 +2034,6 @@ list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
 void
 finish_list_read (st_parameter_dt *dtp)
 {
-  int err;
-
   free_saved (dtp);
 
   fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
@@ -2043,12 +2044,22 @@ finish_list_read (st_parameter_dt *dtp)
       return;
     }
 
-  err = eat_line (dtp);
-  if (err == LIBERROR_END)
+  if (!is_internal_unit (dtp))
+    {
+      int c;
+      c = next_char (dtp);
+      if (c == EOF)
     {
       free_line (dtp);
       hit_eof (dtp);
+	  return;
+    }
+      if (c != '\n')
+	eat_line (dtp);
     }
+
+  free_line (dtp);
+
 }
 
 /*			NAMELIST INPUT
diff --git a/gcc-4.8/libgfortran/io/read.c b/gcc-4.8/libgfortran/io/read.c
index 2da1048f8..f45e1b4ed 100644
--- a/gcc-4.8/libgfortran/io/read.c
+++ b/gcc-4.8/libgfortran/io/read.c
@@ -655,7 +655,13 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 	
       if (c == ' ')
         {
-	  if (dtp->u.p.blank_status == BLANK_NULL) continue;
+	  if (dtp->u.p.blank_status == BLANK_NULL)
+	    {
+	      /* Skip spaces.  */
+	      for ( ; w > 0; p++, w--)
+		if (*p != ' ') break; 
+	      continue;
+	    }
 	  if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
         }
         
diff --git a/gcc-4.8/libgfortran/io/unit.c b/gcc-4.8/libgfortran/io/unit.c
index f8c1516e0..d1b1a712e 100644
--- a/gcc-4.8/libgfortran/io/unit.c
+++ b/gcc-4.8/libgfortran/io/unit.c
@@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include "unix.h"
 #include <stdlib.h>
 #include <string.h>
+#include <stdbool.h>
 
 
 /* IO locking rules:
@@ -375,6 +376,36 @@ find_or_create_unit (int n)
 }
 
 
+/* Helper function to check rank, stride, format string, and namelist.
+   This is used for optimization. You can't trim out blanks or shorten
+   the string if trailing spaces are significant.  */
+static bool
+is_trim_ok (st_parameter_dt *dtp)
+{
+  /* Check rank and stride.  */
+  if (dtp->internal_unit_desc)
+    return false;
+  /* Format strings can not have 'BZ' or '/'.  */
+  if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
+    {
+      char *p = dtp->format;
+      off_t i;
+      if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
+	return false;
+      for (i = 0; i < dtp->format_len; i++)
+	{
+	  if (p[i] == '/') return false;
+	  if (p[i] == 'b' || p[i] == 'B')
+	    if (p[i+1] == 'z' || p[i+1] == 'Z')
+	      return false;
+	}
+    }
+  if (dtp->u.p.ionml) /* A namelist.  */
+    return false;
+  return true;
+}
+
+
 gfc_unit *
 get_internal_unit (st_parameter_dt *dtp)
 {
@@ -402,6 +433,22 @@ get_internal_unit (st_parameter_dt *dtp)
      some other file I/O unit.  */
   iunit->unit_number = -1;
 
+  /* As an optimization, adjust the unit record length to not
+     include trailing blanks. This will not work under certain conditions
+     where trailing blanks have significance.  */
+  if (dtp->u.p.mode == READING && is_trim_ok (dtp))
+    {
+      int len;
+      if (dtp->common.unit == 0)
+	  len = string_len_trim (dtp->internal_unit_len,
+						   dtp->internal_unit);
+      else
+	  len = string_len_trim_char4 (dtp->internal_unit_len,
+			      (const gfc_char4_t*) dtp->internal_unit);
+      dtp->internal_unit_len = len; 
+      iunit->recl = dtp->internal_unit_len;
+    }
+
   /* Set up the looping specification from the array descriptor, if any.  */
 
   if (is_array_io (dtp))
@@ -414,27 +461,6 @@ get_internal_unit (st_parameter_dt *dtp)
 
       start_record *= iunit->recl;
     }
-  else
-    {
-      /* If we are not processing an array, adjust the unit record length not
-	 to include trailing blanks for list-formatted reads.  */
-      if (dtp->u.p.mode == READING && !(dtp->common.flags & IOPARM_DT_HAS_FORMAT))
-	{
-	  if (dtp->common.unit == 0)
-	    {
-	      dtp->internal_unit_len =
-		string_len_trim (dtp->internal_unit_len, dtp->internal_unit);
-	      iunit->recl = dtp->internal_unit_len;
-	    }
-	  else
-	    {
-	      dtp->internal_unit_len =
-		string_len_trim_char4 (dtp->internal_unit_len,
-				       (const gfc_char4_t*) dtp->internal_unit);
-	      iunit->recl = dtp->internal_unit_len;
-	    }
-	}
-    }
 
   /* Set initial values for unit parameters.  */
   if (dtp->common.unit)
diff --git a/gcc-4.8/libgfortran/io/write_float.def b/gcc-4.8/libgfortran/io/write_float.def
index 5b76fd596..acfa125cf 100644
--- a/gcc-4.8/libgfortran/io/write_float.def
+++ b/gcc-4.8/libgfortran/io/write_float.def
@@ -125,8 +125,6 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   int nzero;
   /* Number of digits after the decimal point.  */
   int nafter;
-  /* Number of zeros after the decimal point, whatever the precision.  */
-  int nzero_real;
   int leadzero;
   int nblanks;
   int ndigits, edigits;
@@ -138,7 +136,6 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   p = dtp->u.p.scale_factor;
 
   rchar = '5';
-  nzero_real = -1;
 
   /* We should always know the field width and precision.  */
   if (d < 0)
@@ -191,7 +188,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
 	      if (nafter < 0)
 		nafter = 0;
 	      nafter = d;
-	      nzero = nzero_real = 0;
+	      nzero = 0;
 	    }
 	  else /* p < 0  */
 	    {
@@ -211,14 +208,13 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
 		  nafter = d + nbefore;
 		  nbefore = 0;
 		}
-	      nzero_real = nzero;
 	      if (nzero > d)
 		nzero = d;
 	    }
 	}
       else
 	{
-	  nzero = nzero_real = 0;
+	  nzero = 0;
 	  nafter = d;
 	}
 
@@ -373,7 +369,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   updown:
 
   rchar = '0';
-  if (w > 0 && d == 0 && p == 0)
+  if (ft != FMT_F && w > 0 && d == 0 && p == 0)
     nbefore = 1;
   /* Scan for trailing zeros to see if we really need to round it.  */
   for(i = nbefore + nafter; i < ndigits; i++)
@@ -386,13 +382,14 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   do_rnd:
  
   if (nbefore + nafter == 0)
+    /* Handle the case Fw.0 and value < 1.0 */
     {
       ndigits = 0;
-      if (nzero_real == d && digits[0] >= rchar)
+      if (digits[0] >= rchar)
 	{
 	  /* We rounded to zero but shouldn't have */
-	  nzero--;
-	  nafter = 1;
+	  nbefore = 1;
+	  digits--;
 	  digits[0] = '1';
 	  ndigits = 1;
 	}
@@ -990,13 +987,14 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
   int d = f->u.real.d;\
   int w = f->u.real.w;\
   fnode newf;\
-  GFC_REAL_ ## x rexp_d, r = 0.5;\
+  GFC_REAL_ ## x exp_d, r = 0.5, r_sc;\
   int low, high, mid;\
   int ubound, lbound;\
   char *p, pad = ' ';\
   int save_scale_factor, nb = 0;\
   try result;\
   int nprinted, precision;\
+  volatile GFC_REAL_ ## x temp;\
 \
   save_scale_factor = dtp->u.p.scale_factor;\
 \
@@ -1015,10 +1013,13 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
 	break;\
     }\
 \
-  rexp_d = calculate_exp_ ## x (-d);\
-  if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\
+  exp_d = calculate_exp_ ## x (d);\
+  r_sc = (1 - r / exp_d);\
+  temp = 0.1 * r_sc;\
+  if ((m > 0.0 && ((m < temp) || (r >= (exp_d - m))))\
       || ((m == 0.0) && !(compile_options.allow_std\
-			  & (GFC_STD_F2003 | GFC_STD_F2008))))\
+			  & (GFC_STD_F2003 | GFC_STD_F2008)))\
+      ||  d == 0)\
     { \
       newf.format = FMT_E;\
       newf.u.real.w = w;\
@@ -1038,10 +1039,9 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
 \
   while (low <= high)\
     { \
-      volatile GFC_REAL_ ## x temp;\
       mid = (low + high) / 2;\
 \
-      temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\
+      temp = (calculate_exp_ ## x (mid - 1) * r_sc);\
 \
       if (m < temp)\
         { \
@@ -1121,14 +1121,36 @@ OUTPUT_FLOAT_FMT_G(16,L)
 /* EN format is tricky since the number of significant digits depends
    on the magnitude.  Solve it by first printing a temporary value and
    figure out the number of significant digits from the printed
-   exponent.  */
+   exponent.  Values y, 0.95*10.0**e <= y <10.0**e, are rounded to
+   10.0**e even when the final result will not be rounded to 10.0**e.
+   For these values the exponent returned by atoi has to be decremented
+   by one. The values y in the ranges
+       (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))  
+        (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
+         (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
+   are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)),
+   100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0
+   represents d zeroes, by the lines 279 to 297. */
 
 #define EN_PREC(x,y)\
 {\
-    GFC_REAL_ ## x tmp;				\
-    tmp = * (GFC_REAL_ ## x *)source;				\
+    volatile GFC_REAL_ ## x tmp, one = 1.0;\
+    tmp = * (GFC_REAL_ ## x *)source;\
     if (isfinite (tmp))						\
-      nprinted = DTOA(y,0,tmp);					\
+      {\
+	nprinted = DTOA(y,0,tmp);\
+	int e = atoi (&buffer[4]);\
+	if (buffer[1] == '1')\
+	  {\
+	    tmp = (calculate_exp_ ## x (-e)) * tmp;\
+	    tmp = one - (tmp < 0 ? -tmp : tmp);	\
+	    if (tmp > 0)\
+	      e = e - 1;\
+	  }\
+	nbefore = e%3;\
+	if (nbefore < 0)\
+	  nbefore = 3 + nbefore;\
+      }\
     else\
       nprinted = -1;\
 }\
@@ -1140,6 +1162,7 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
   int nprinted;
   char buffer[10];
   const size_t size = 10;
+  int nbefore; /* digits before decimal point - 1.  */
 
   switch (len)
     {
@@ -1172,16 +1195,6 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
   if (nprinted == -1)
     return -1;
 
-  int e = atoi (&buffer[5]);
-  int nbefore; /* digits before decimal point - 1.  */
-  if (e >= 0)
-    nbefore = e % 3;
-  else
-    {
-      nbefore = (-e) % 3;
-      if (nbefore != 0)
-	nbefore = 3 - nbefore;
-    }
   int prec = f->u.real.d + nbefore;
   if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
       && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)