From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified
 gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream
 tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
---
 libgfortran/io/write_float.def | 1087 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 1087 insertions(+)
 create mode 100644 libgfortran/io/write_float.def

(limited to 'libgfortran/io/write_float.def')

diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
new file mode 100644
index 000000000..b72cf9f56
--- /dev/null
+++ b/libgfortran/io/write_float.def
@@ -0,0 +1,1087 @@
+/* Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+   Write float code factoring to this file by Jerry DeLisle   
+   F2003 I/O support contributed by Jerry DeLisle
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+
+typedef enum
+{ S_NONE, S_MINUS, S_PLUS }
+sign_t;
+
+/* Given a flag that indicates if a value is negative or not, return a
+   sign_t that gives the sign that we need to produce.  */
+
+static sign_t
+calculate_sign (st_parameter_dt *dtp, int negative_flag)
+{
+  sign_t s = S_NONE;
+
+  if (negative_flag)
+    s = S_MINUS;
+  else
+    switch (dtp->u.p.sign_status)
+      {
+      case SIGN_SP:	/* Show sign. */
+	s = S_PLUS;
+	break;
+      case SIGN_SS:	/* Suppress sign. */
+	s = S_NONE;
+	break;
+      case SIGN_S:	/* Processor defined. */
+      case SIGN_UNSPECIFIED:
+	s = options.optional_plus ? S_PLUS : S_NONE;
+	break;
+      }
+
+  return s;
+}
+
+
+/* Output a real number according to its format which is FMT_G free.  */
+
+static try
+output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, 
+	      int sign_bit, bool zero_flag, int ndigits, int edigits)
+{
+  char *out;
+  char *digits;
+  int e;
+  char expchar, rchar;
+  format_token ft;
+  int w;
+  int d;
+  /* Number of digits before the decimal point.  */
+  int nbefore;
+  /* Number of zeros after the decimal point.  */
+  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 i;
+  sign_t sign;
+
+  ft = f->format;
+  w = f->u.real.w;
+  d = f->u.real.d;
+
+  rchar = '5';
+  nzero_real = -1;
+
+  /* We should always know the field width and precision.  */
+  if (d < 0)
+    internal_error (&dtp->common, "Unspecified precision");
+
+  sign = calculate_sign (dtp, sign_bit);
+  
+  /* The following code checks the given string has punctuation in the correct
+     places.  Uncomment if needed for debugging.
+     if (d != 0 && ((buffer[2] != '.' && buffer[2] != ',')
+		    || buffer[ndigits + 2] != 'e'))
+       internal_error (&dtp->common, "printf is broken");  */
+
+  /* Read the exponent back in.  */
+  e = atoi (&buffer[ndigits + 3]) + 1;
+
+  /* Make sure zero comes out as 0.0e0.   */
+  if (zero_flag)
+    e = 0;
+
+  /* Normalize the fractional component.  */
+  buffer[2] = buffer[1];
+  digits = &buffer[2];
+
+  /* Figure out where to place the decimal point.  */
+  switch (ft)
+    {
+    case FMT_F:
+      if (d == 0 && e <= 0 && dtp->u.p.scale_factor == 0)
+	{
+	  memmove (digits + 1, digits, ndigits - 1);
+	  digits[0] = '0';
+	  e++;
+	}
+
+      nbefore = e + dtp->u.p.scale_factor;
+      if (nbefore < 0)
+	{
+	  nzero = -nbefore;
+          nzero_real = nzero;
+	  if (nzero > d)
+	    nzero = d;
+	  nafter = d - nzero;
+	  nbefore = 0;
+	}
+      else
+	{
+	  nzero = 0;
+	  nafter = d;
+	}
+      expchar = 0;
+      break;
+
+    case FMT_E:
+    case FMT_D:
+      i = dtp->u.p.scale_factor;
+      if (d <= 0 && i == 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
+			  "greater than zero in format specifier 'E' or 'D'");
+	  return FAILURE;
+	}
+      if (i <= -d || i >= d + 2)
+	{
+	  generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
+			  "out of range in format specifier 'E' or 'D'");
+	  return FAILURE;
+	}
+
+      if (!zero_flag)
+	e -= i;
+      if (i < 0)
+	{
+	  nbefore = 0;
+	  nzero = -i;
+	  nafter = d + i;
+	}
+      else if (i > 0)
+	{
+	  nbefore = i;
+	  nzero = 0;
+	  nafter = (d - i) + 1;
+	}
+      else /* i == 0 */
+	{
+	  nbefore = 0;
+	  nzero = 0;
+	  nafter = d;
+	}
+
+      if (ft == FMT_E)
+	expchar = 'E';
+      else
+	expchar = 'D';
+      break;
+
+    case FMT_EN:
+      /* The exponent must be a multiple of three, with 1-3 digits before
+	 the decimal point.  */
+      if (!zero_flag)
+        e--;
+      if (e >= 0)
+	nbefore = e % 3;
+      else
+	{
+	  nbefore = (-e) % 3;
+	  if (nbefore != 0)
+	    nbefore = 3 - nbefore;
+	}
+      e -= nbefore;
+      nbefore++;
+      nzero = 0;
+      nafter = d;
+      expchar = 'E';
+      break;
+
+    case FMT_ES:
+      if (!zero_flag)
+        e--;
+      nbefore = 1;
+      nzero = 0;
+      nafter = d;
+      expchar = 'E';
+      break;
+
+    default:
+      /* Should never happen.  */
+      internal_error (&dtp->common, "Unexpected format token");
+    }
+
+  /* Round the value.  The value being rounded is an unsigned magnitude.
+     The ROUND_COMPATIBLE is rounding away from zero when there is a tie.  */
+  switch (dtp->u.p.current_unit->round_status)
+    {
+      case ROUND_ZERO: /* Do nothing and truncation occurs.  */
+	goto skip;
+      case ROUND_UP:
+	if (sign_bit)
+	  goto skip;
+	rchar = '0';
+	break;
+      case ROUND_DOWN:
+	if (!sign_bit)
+	  goto skip;
+	rchar = '0';
+	break;
+      case ROUND_NEAREST:
+	/* Round compatible unless there is a tie. A tie is a 5 with
+	   all trailing zero's.  */
+	i = nafter + nbefore;
+	if (digits[i] == '5')
+	  {
+	    for(i++ ; i < ndigits; i++)
+	      {
+		if (digits[i] != '0')
+		  goto do_rnd;
+	      }
+	    /* It is a  tie so round to even.  */
+	    switch (digits[nafter + nbefore - 1])
+	      {
+		case '1':
+		case '3':
+		case '5':
+		case '7':
+		case '9':
+		  /* If odd, round away from zero to even.  */
+		  break;
+		default:
+		  /* If even, skip rounding, truncate to even.  */
+		  goto skip;
+	      }
+	  }
+	 /* Fall through.  */ 
+      case ROUND_PROCDEFINED:
+      case ROUND_UNSPECIFIED:
+      case ROUND_COMPATIBLE:
+	rchar = '5';
+	/* Just fall through and do the actual rounding.  */
+    }
+    
+  do_rnd:
+ 
+  if (nbefore + nafter == 0)
+    {
+      ndigits = 0;
+      if (nzero_real == d && digits[0] >= rchar)
+	{
+	  /* We rounded to zero but shouldn't have */
+	  nzero--;
+	  nafter = 1;
+	  digits[0] = '1';
+	  ndigits = 1;
+	}
+    }
+  else if (nbefore + nafter < ndigits)
+    {
+      ndigits = nbefore + nafter;
+      i = ndigits;
+      if (digits[i] >= rchar)
+	{
+	  /* Propagate the carry.  */
+	  for (i--; i >= 0; i--)
+	    {
+	      if (digits[i] != '9')
+		{
+		  digits[i]++;
+		  break;
+		}
+	      digits[i] = '0';
+	    }
+
+	  if (i < 0)
+	    {
+	      /* The carry overflowed.  Fortunately we have some spare
+	         space at the start of the buffer.  We may discard some
+	         digits, but this is ok because we already know they are
+	         zero.  */
+	      digits--;
+	      digits[0] = '1';
+	      if (ft == FMT_F)
+		{
+		  if (nzero > 0)
+		    {
+		      nzero--;
+		      nafter++;
+		    }
+		  else
+		    nbefore++;
+		}
+	      else if (ft == FMT_EN)
+		{
+		  nbefore++;
+		  if (nbefore == 4)
+		    {
+		      nbefore = 1;
+		      e += 3;
+		    }
+		}
+	      else
+		e++;
+	    }
+	}
+    }
+
+  skip:
+
+  /* Calculate the format of the exponent field.  */
+  if (expchar)
+    {
+      edigits = 1;
+      for (i = abs (e); i >= 10; i /= 10)
+	edigits++;
+
+      if (f->u.real.e < 0)
+	{
+	  /* Width not specified.  Must be no more than 3 digits.  */
+	  if (e > 999 || e < -999)
+	    edigits = -1;
+	  else
+	    {
+	      edigits = 4;
+	      if (e > 99 || e < -99)
+		expchar = ' ';
+	    }
+	}
+      else
+	{
+	  /* Exponent width specified, check it is wide enough.  */
+	  if (edigits > f->u.real.e)
+	    edigits = -1;
+	  else
+	    edigits = f->u.real.e + 2;
+	}
+    }
+  else
+    edigits = 0;
+
+  /* Scan the digits string and count the number of zeros.  If we make it
+     all the way through the loop, we know the value is zero after the
+     rounding completed above.  */
+  for (i = 0; i < ndigits; i++)
+    {
+      if (digits[i] != '0')
+	break;
+    }
+
+  /* To format properly, we need to know if the rounded result is zero and if
+     so, we set the zero_flag which may have been already set for
+     actual zero.  */
+  if (i == ndigits)
+    {
+      zero_flag = true;
+      /* The output is zero, so set the sign according to the sign bit unless
+	 -fno-sign-zero was specified.  */
+      if (compile_options.sign_zero == 1)
+        sign = calculate_sign (dtp, sign_bit);
+      else
+	sign = calculate_sign (dtp, 0);
+    }
+
+  /* Pick a field size if none was specified, taking into account small
+     values that may have been rounded to zero.  */
+  if (w <= 0)
+    {
+      if (zero_flag)
+	w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
+      else
+	{
+	  w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
+	  w = w == 1 ? 2 : w;
+	}
+    }
+  
+  /* Work out how much padding is needed.  */
+  nblanks = w - (nbefore + nzero + nafter + edigits + 1);
+  if (sign != S_NONE)
+    nblanks--;
+
+  if (dtp->u.p.g0_no_blanks)
+    {
+      w -= nblanks;
+      nblanks = 0;
+    }
+
+  /* Create the ouput buffer.  */
+  out = write_block (dtp, w);
+  if (out == NULL)
+    return FAILURE;
+
+  /* Check the value fits in the specified field width.  */
+  if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
+    {
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *out4 = (gfc_char4_t *) out;
+	  memset4 (out4, '*', w);
+	  return FAILURE;
+	}
+      star_fill (out, w);
+      return FAILURE;
+    }
+
+  /* See if we have space for a zero before the decimal point.  */
+  if (nbefore == 0 && nblanks > 0)
+    {
+      leadzero = 1;
+      nblanks--;
+    }
+  else
+    leadzero = 0;
+
+  /* For internal character(kind=4) units, we duplicate the code used for
+     regular output slightly modified.  This needs to be maintained
+     consistent with the regular code that follows this block.  */
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *out4 = (gfc_char4_t *) out;
+      /* Pad to full field width.  */
+
+      if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
+	{
+	  memset4 (out4, ' ', nblanks);
+	  out4 += nblanks;
+	}
+
+      /* Output the initial sign (if any).  */
+      if (sign == S_PLUS)
+	*(out4++) = '+';
+      else if (sign == S_MINUS)
+	*(out4++) = '-';
+
+      /* Output an optional leading zero.  */
+      if (leadzero)
+	*(out4++) = '0';
+
+      /* Output the part before the decimal point, padding with zeros.  */
+      if (nbefore > 0)
+	{
+	  if (nbefore > ndigits)
+	    {
+	      i = ndigits;
+	      memcpy4 (out4, digits, i);
+	      ndigits = 0;
+	      while (i < nbefore)
+		out4[i++] = '0';
+	    }
+	  else
+	    {
+	      i = nbefore;
+	      memcpy4 (out4, digits, i);
+	      ndigits -= i;
+	    }
+
+	  digits += i;
+	  out4 += nbefore;
+	}
+
+      /* Output the decimal point.  */
+      *(out4++) = dtp->u.p.current_unit->decimal_status
+		    == DECIMAL_POINT ? '.' : ',';
+
+      /* Output leading zeros after the decimal point.  */
+      if (nzero > 0)
+	{
+	  for (i = 0; i < nzero; i++)
+	    *(out4++) = '0';
+	}
+
+      /* Output digits after the decimal point, padding with zeros.  */
+      if (nafter > 0)
+	{
+	  if (nafter > ndigits)
+	    i = ndigits;
+	  else
+	    i = nafter;
+
+	  memcpy4 (out4, digits, i);
+	  while (i < nafter)
+	    out4[i++] = '0';
+
+	  digits += i;
+	  ndigits -= i;
+	  out4 += nafter;
+	}
+
+      /* Output the exponent.  */
+      if (expchar)
+	{
+	  if (expchar != ' ')
+	    {
+	      *(out4++) = expchar;
+	      edigits--;
+	    }
+#if HAVE_SNPRINTF
+	  snprintf (buffer, size, "%+0*d", edigits, e);
+#else
+	  sprintf (buffer, "%+0*d", edigits, e);
+#endif
+	  memcpy4 (out4, buffer, edigits);
+	}
+
+      if (dtp->u.p.no_leading_blank)
+	{
+	  out4 += edigits;
+	  memset4 (out4, ' ' , nblanks);
+	  dtp->u.p.no_leading_blank = 0;
+	}
+      return SUCCESS;
+    } /* End of character(kind=4) internal unit code.  */
+
+  /* Pad to full field width.  */
+
+  if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
+    {
+      memset (out, ' ', nblanks);
+      out += nblanks;
+    }
+
+  /* Output the initial sign (if any).  */
+  if (sign == S_PLUS)
+    *(out++) = '+';
+  else if (sign == S_MINUS)
+    *(out++) = '-';
+
+  /* Output an optional leading zero.  */
+  if (leadzero)
+    *(out++) = '0';
+
+  /* Output the part before the decimal point, padding with zeros.  */
+  if (nbefore > 0)
+    {
+      if (nbefore > ndigits)
+	{
+	  i = ndigits;
+	  memcpy (out, digits, i);
+	  ndigits = 0;
+	  while (i < nbefore)
+	    out[i++] = '0';
+	}
+      else
+	{
+	  i = nbefore;
+	  memcpy (out, digits, i);
+	  ndigits -= i;
+	}
+
+      digits += i;
+      out += nbefore;
+    }
+
+  /* Output the decimal point.  */
+  *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
+
+  /* Output leading zeros after the decimal point.  */
+  if (nzero > 0)
+    {
+      for (i = 0; i < nzero; i++)
+	*(out++) = '0';
+    }
+
+  /* Output digits after the decimal point, padding with zeros.  */
+  if (nafter > 0)
+    {
+      if (nafter > ndigits)
+	i = ndigits;
+      else
+	i = nafter;
+
+      memcpy (out, digits, i);
+      while (i < nafter)
+	out[i++] = '0';
+
+      digits += i;
+      ndigits -= i;
+      out += nafter;
+    }
+
+  /* Output the exponent.  */
+  if (expchar)
+    {
+      if (expchar != ' ')
+	{
+	  *(out++) = expchar;
+	  edigits--;
+	}
+#if HAVE_SNPRINTF
+      snprintf (buffer, size, "%+0*d", edigits, e);
+#else
+      sprintf (buffer, "%+0*d", edigits, e);
+#endif
+      memcpy (out, buffer, edigits);
+    }
+
+  if (dtp->u.p.no_leading_blank)
+    {
+      out += edigits;
+      memset( out , ' ' , nblanks );
+      dtp->u.p.no_leading_blank = 0;
+    }
+
+#undef STR
+#undef STR1
+#undef MIN_FIELD_WIDTH
+  return SUCCESS;
+}
+
+
+/* Write "Infinite" or "Nan" as appropriate for the given format.  */
+
+static void
+write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
+{
+  char * p, fin;
+  int nb = 0;
+  sign_t sign;
+  int mark;
+
+  if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
+    {
+      sign = calculate_sign (dtp, sign_bit);
+      mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
+
+      nb =  f->u.real.w;
+  
+      /* If the field width is zero, the processor must select a width 
+	 not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
+     
+      if (nb == 0)
+	{
+	  if (isnan_flag)
+	    nb = 3;
+	  else
+	    nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
+	}
+      p = write_block (dtp, nb);
+      if (p == NULL)
+	return;
+      if (nb < 3)
+	{
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
+	      memset4 (p4, '*', nb);
+	    }
+	  else
+	    memset (p, '*', nb);
+	  return;
+	}
+
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;
+	  memset4 (p4, ' ', nb);
+	}
+      else
+	memset(p, ' ', nb);
+
+      if (!isnan_flag)
+	{
+	  if (sign_bit)
+	    {
+	      /* If the sign is negative and the width is 3, there is
+		 insufficient room to output '-Inf', so output asterisks */
+	      if (nb == 3)
+		{
+		  if (unlikely (is_char4_unit (dtp)))
+		    {
+		      gfc_char4_t *p4 = (gfc_char4_t *) p;
+		      memset4 (p4, '*', nb);
+		    }
+		  else
+		    memset (p, '*', nb);
+		  return;
+		}
+	      /* The negative sign is mandatory */
+	      fin = '-';
+	    }    
+	  else
+	    /* The positive sign is optional, but we output it for
+	       consistency */
+	    fin = '+';
+	    
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+	      if (nb > mark)
+		/* We have room, so output 'Infinity' */
+		memcpy4 (p4 + nb - 8, "Infinity", 8);
+	      else
+		/* For the case of width equals mark, there is not enough room
+		   for the sign and 'Infinity' so we go with 'Inf' */
+		memcpy4 (p4 + nb - 3, "Inf", 3);
+
+	      if (sign == S_PLUS || sign == S_MINUS)
+		{
+		  if (nb < 9 && nb > 3)
+		    /* Put the sign in front of Inf */
+		    p4[nb - 4] = (gfc_char4_t) fin;
+		  else if (nb > 8)
+		    /* Put the sign in front of Infinity */
+		    p4[nb - 9] = (gfc_char4_t) fin;
+		}
+	      return;
+	    }
+
+	  if (nb > mark)
+	    /* We have room, so output 'Infinity' */
+	    memcpy(p + nb - 8, "Infinity", 8);
+	  else
+	    /* For the case of width equals 8, there is not enough room
+	       for the sign and 'Infinity' so we go with 'Inf' */
+	    memcpy(p + nb - 3, "Inf", 3);
+
+	  if (sign == S_PLUS || sign == S_MINUS)
+	    {
+	      if (nb < 9 && nb > 3)
+		p[nb - 4] = fin;  /* Put the sign in front of Inf */
+	      else if (nb > 8)
+		p[nb - 9] = fin;  /* Put the sign in front of Infinity */
+	    }
+	}
+      else
+        {
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
+	      memcpy4 (p4 + nb - 3, "NaN", 3);
+	    }
+	  else
+	    memcpy(p + nb - 3, "NaN", 3);
+	}
+      return;
+    }
+}
+
+
+/* Returns the value of 10**d.  */
+
+#define CALCULATE_EXP(x) \
+inline static GFC_REAL_ ## x \
+calculate_exp_ ## x  (int d)\
+{\
+  int i;\
+  GFC_REAL_ ## x r = 1.0;\
+  for (i = 0; i< (d >= 0 ? d : -d); i++)\
+    r *= 10;\
+  r = (d >= 0) ? r : 1.0 / r;\
+  return r;\
+}
+
+CALCULATE_EXP(4)
+
+CALCULATE_EXP(8)
+
+#ifdef HAVE_GFC_REAL_10
+CALCULATE_EXP(10)
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+CALCULATE_EXP(16)
+#endif
+#undef CALCULATE_EXP
+
+/* Generate corresponding I/O format for FMT_G and output.
+   The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
+   LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
+
+   Data Magnitude                              Equivalent Conversion
+   0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
+   m = 0                                       F(w-n).(d-1), n' '
+   0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
+   1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
+   10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
+   ................                           ..........
+   10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
+   m >= 10**d-0.5                              Ew.d[Ee]
+
+   notes: for Gw.d ,  n' ' means 4 blanks
+          for Gw.dEe, n' ' means e+2 blanks  */
+
+#define OUTPUT_FLOAT_FMT_G(x) \
+static void \
+output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
+		      GFC_REAL_ ## x m, char *buffer, size_t size, \
+		      int sign_bit, bool zero_flag, int ndigits, int edigits) \
+{ \
+  int e = f->u.real.e;\
+  int d = f->u.real.d;\
+  int w = f->u.real.w;\
+  fnode *newf;\
+  GFC_REAL_ ## x rexp_d;\
+  int low, high, mid;\
+  int ubound, lbound;\
+  char *p, pad = ' ';\
+  int save_scale_factor, nb = 0;\
+  try result;\
+\
+  save_scale_factor = dtp->u.p.scale_factor;\
+  newf = (fnode *) get_mem (sizeof (fnode));\
+\
+  rexp_d = calculate_exp_ ## x (-d);\
+  if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\
+      ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
+    { \
+      newf->format = FMT_E;\
+      newf->u.real.w = w;\
+      newf->u.real.d = d;\
+      newf->u.real.e = e;\
+      nb = 0;\
+      goto finish;\
+    }\
+\
+  mid = 0;\
+  low = 0;\
+  high = d + 1;\
+  lbound = 0;\
+  ubound = d + 1;\
+\
+  while (low <= high)\
+    { \
+      GFC_REAL_ ## x temp;\
+      mid = (low + high) / 2;\
+\
+      temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
+\
+      if (m < temp)\
+        { \
+          ubound = mid;\
+          if (ubound == lbound + 1)\
+            break;\
+          high = mid - 1;\
+        }\
+      else if (m > temp)\
+        { \
+          lbound = mid;\
+          if (ubound == lbound + 1)\
+            { \
+              mid ++;\
+              break;\
+            }\
+          low = mid + 1;\
+        }\
+      else\
+	{\
+	  mid++;\
+	  break;\
+	}\
+    }\
+\
+  if (e > 4)\
+    e = 4;\
+  if (e < 0)\
+    nb = 4;\
+  else\
+    nb = e + 2;\
+\
+  nb = nb >= w ? 0 : nb;\
+  newf->format = FMT_F;\
+  newf->u.real.w = f->u.real.w - nb;\
+\
+  if (m == 0.0)\
+    newf->u.real.d = d - 1;\
+  else\
+    newf->u.real.d = - (mid - d - 1);\
+\
+  dtp->u.p.scale_factor = 0;\
+\
+ finish:\
+  result = output_float (dtp, newf, buffer, size, sign_bit, zero_flag, \
+			 ndigits, edigits);\
+  dtp->u.p.scale_factor = save_scale_factor;\
+\
+  free (newf);\
+\
+  if (nb > 0 && !dtp->u.p.g0_no_blanks)\
+    {\
+      p = write_block (dtp, nb);\
+      if (p == NULL)\
+	return;\
+      if (result == FAILURE)\
+        pad = '*';\
+      if (unlikely (is_char4_unit (dtp)))\
+	{\
+	  gfc_char4_t *p4 = (gfc_char4_t *) p;\
+	  memset4 (p4, pad, nb);\
+	}\
+      else\
+	memset (p, pad, nb);\
+    }\
+}\
+
+OUTPUT_FLOAT_FMT_G(4)
+
+OUTPUT_FLOAT_FMT_G(8)
+
+#ifdef HAVE_GFC_REAL_10
+OUTPUT_FLOAT_FMT_G(10)
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+OUTPUT_FLOAT_FMT_G(16)
+#endif
+
+#undef OUTPUT_FLOAT_FMT_G
+
+
+/* Define a macro to build code for write_float.  */
+
+  /* Note: Before output_float is called, sprintf is used to print to buffer the
+     number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
+     (MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
+     before the decimal point.
+
+     #   The result will always contain a decimal point, even if no
+	 digits follow it
+
+     -   The converted value is to be left adjusted on the field boundary
+
+     +   A sign (+ or -) always be placed before a number
+
+     MIN_FIELD_WIDTH  minimum field width
+
+     *   (ndigits-1) is used as the precision
+
+     e format: [-]d.dddeÂ±dd where there is one digit before the
+       decimal-point character and the number of digits after it is
+       equal to the precision. The exponent always contains at least two
+       digits; if the value is zero, the exponent is 00.  */
+
+#ifdef HAVE_SNPRINTF
+
+#define DTOA \
+snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	  "e", ndigits - 1, tmp);
+
+#define DTOAL \
+snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	  "Le", ndigits - 1, tmp);
+
+#else
+
+#define DTOA \
+sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	 "e", ndigits - 1, tmp);
+
+#define DTOAL \
+sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+	 "Le", ndigits - 1, tmp);
+
+#endif
+
+#if defined(GFC_REAL_16_IS_FLOAT128)
+#define DTOAQ \
+__qmath_(quadmath_snprintf) (buffer, sizeof buffer, \
+			     "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+			     "Qe", ndigits - 1, tmp);
+#endif
+
+#define WRITE_FLOAT(x,y)\
+{\
+	GFC_REAL_ ## x tmp;\
+	tmp = * (GFC_REAL_ ## x *)source;\
+	sign_bit = signbit (tmp);\
+	if (!isfinite (tmp))\
+	  { \
+	    write_infnan (dtp, f, isnan (tmp), sign_bit);\
+	    return;\
+	  }\
+	tmp = sign_bit ? -tmp : tmp;\
+	zero_flag = (tmp == 0.0);\
+\
+	DTOA ## y\
+\
+	if (f->format != FMT_G)\
+	  output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
+			edigits);\
+	else \
+	  output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
+				    zero_flag, ndigits, edigits);\
+}\
+
+/* Output a real number according to its format.  */
+
+static void
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+
+#if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
+# define MIN_FIELD_WIDTH 48
+#else
+# define MIN_FIELD_WIDTH 31
+#endif
+#define STR(x) STR1(x)
+#define STR1(x) #x
+
+  /* This must be large enough to accurately hold any value.  */
+  char buffer[MIN_FIELD_WIDTH+1];
+  int sign_bit, ndigits, edigits;
+  bool zero_flag;
+  size_t size;
+
+  size = MIN_FIELD_WIDTH+1;
+
+  /* printf pads blanks for us on the exponent so we just need it big enough
+     to handle the largest number of exponent digits expected.  */
+  edigits=4;
+
+  if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G 
+      || ((f->format == FMT_D || f->format == FMT_E)
+      && dtp->u.p.scale_factor != 0))
+    {
+      /* Always convert at full precision to avoid double rounding.  */
+      ndigits = MIN_FIELD_WIDTH - 4 - edigits;
+    }
+  else
+    {
+      /* The number of digits is known, so let printf do the rounding.  */
+      if (f->format == FMT_ES)
+	ndigits = f->u.real.d + 1;
+      else
+	ndigits = f->u.real.d;
+      if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
+	ndigits = MIN_FIELD_WIDTH - 4 - edigits;
+    }
+
+  switch (len)
+    {
+    case 4:
+      WRITE_FLOAT(4,)
+      break;
+
+    case 8:
+      WRITE_FLOAT(8,)
+      break;
+
+#ifdef HAVE_GFC_REAL_10
+    case 10:
+      WRITE_FLOAT(10,L)
+      break;
+#endif
+#ifdef HAVE_GFC_REAL_16
+    case 16:
+# ifdef GFC_REAL_16_IS_FLOAT128
+      WRITE_FLOAT(16,Q)
+# else
+      WRITE_FLOAT(16,L)
+# endif
+      break;
+#endif
+    default:
+      internal_error (NULL, "bad real kind");
+    }
+}
-- 
cgit v1.2.3

