write.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

	      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++;
	    }
	}
    }

  /* 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;

  /* Pick a field size if none was specified.  */
  if (w <= 0)
    w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);

  /* Create the ouput buffer.  */
  out = write_block (dtp, w);
  if (out == NULL)
    return;

  /* Zero values always output as positive, even if the value was negative
     before rounding.  */
  for (i = 0; i < ndigits; i++)
    {
      if (digits[i] != '0')
	break;
    }
  if (i == ndigits)
    sign = calculate_sign (dtp, 0);

  /* Work out how much padding is needed.  */
  nblanks = w - (nbefore + nzero + nafter + edigits + 1);
  if (sign != SIGN_NONE)
    nblanks--;

  /* Check the value fits in the specified field width.  */
  if (nblanks < 0 || edigits == -1)
    {
      star_fill (out, w);
      return;
    }

  /* See if we have space for a zero before the decimal point.  */
  if (nbefore == 0 && nblanks > 0)
    {
      leadzero = 1;
      nblanks--;
    }
  else
    leadzero = 0;

  /* 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 == SIGN_PLUS)
    *(out++) = '+';
  else if (sign == SIGN_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;
      else
	i = nbefore;

      memcpy (out, digits, i);
      while (i < nbefore)
	out[i++] = '0';

      digits += i;
      ndigits -= i;
      out += nbefore;
    }
  /* Output the decimal point.  */
  *(out++) = '.';

  /* 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, 32, "%+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;
    }
}


void
write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
{
  char *p;
  GFC_INTEGER_LARGEST n;

  p = write_block (dtp, f->u.w);
  if (p == NULL)
    return;

  memset (p, ' ', f->u.w - 1);
  n = extract_int (source, len);
  p[f->u.w - 1] = (n) ? 'T' : 'F';
}

/* Output a real number according to its format.  */

static void
write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
  GFC_REAL_LARGEST n;
  int nb =0, res, save_scale_factor;
  char * p, fin;
  fnode *f2 = NULL;

  n = extract_real (source, len);

  if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
    {
      res = isfinite (n); 
      if (res == 0)
	{
	  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) nb = 4;
	  p = write_block (dtp, nb);
          if (p == NULL)
            return;
	  if (nb < 3)
	    {
	      memset (p, '*',nb);
	      return;
	    }

	  memset(p, ' ', nb);
	  res = !isnan (n);
	  if (res != 0)
	    {
	      if (signbit(n))
	        {
	        
	          /* If the sign is negative and the width is 3, there is
	             insufficient room to output '-Inf', so output asterisks */
	             
	          if (nb == 3)
	            {
	              memset (p, '*',nb);
	              return;
	            }
	            
	          /* The negative sign is mandatory */
	            
	          fin = '-';
		}    
	      else
	      
	          /* The positive sign is optional, but we output it for
	             consistency */
	             
		  fin = '+';

	      if (nb > 8)
	      
	        /* 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 (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
	    memcpy(p + nb - 3, "NaN", 3);
	  return;
	}
    }

  if (f->format != FMT_G)
    output_float (dtp, f, n);
  else
    {
      save_scale_factor = dtp->u.p.scale_factor;
      f2 = calculate_G_format (dtp, f, n, &nb);
      output_float (dtp, f2, n);
      dtp->u.p.scale_factor = save_scale_factor;
      if (f2 != NULL)
        free_mem(f2);

      if (nb > 0)
        {
	  p = write_block (dtp, nb);
          if (p == NULL)
            return;
          memset (p, ' ', nb);
        }
    }
}


static void
write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
           const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
{
  GFC_UINTEGER_LARGEST n = 0;
  int w, m, digits, nzero, nblank;
  char *p;
  const char *q;
  char itoa_buf[GFC_BTOA_BUF_SIZE];

  w = f->u.integer.w;
  m = f->u.integer.m;

  n = extract_uint (source, len);

  /* Special case:  */

  if (m == 0 && n == 0)
    {
      if (w == 0)
        w = 1;

      p = write_block (dtp, w);
      if (p == NULL)
        return;

      memset (p, ' ', w);
      goto done;
    }

  q = conv (n, itoa_buf, sizeof (itoa_buf));
  digits = strlen (q);

  /* Select a width if none was specified.  The idea here is to always
     print something.  */

  if (w == 0)
    w = ((digits < m) ? m : digits);

  p = write_block (dtp, w);
  if (p == NULL)
    return;

  nzero = 0;
  if (digits < m)
    nzero = m - digits;

  /* See if things will work.  */

  nblank = w - (nzero + digits);

  if (nblank < 0)
    {
      star_fill (p, w);
      goto done;
    }


  if (!dtp->u.p.no_leading_blank)
    {
      memset (p, ' ', nblank);
      p += nblank;
      memset (p, '0', nzero);
      p += nzero;
      memcpy (p, q, digits);
    }
  else
    {
      memset (p, '0', nzero);
      p += nzero;
      memcpy (p, q, digits);
      p += digits;
      memset (p, ' ', nblank);
      dtp->u.p.no_leading_blank = 0;
    }

 done:
  return;
}

static void
write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
	       int len,
               const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
{
  GFC_INTEGER_LARGEST n = 0;
  int w, m, digits, nsign, nzero, nblank;
  char *p;
  const char *q;
  sign_t sign;
  char itoa_buf[GFC_BTOA_BUF_SIZE];

  w = f->u.integer.w;
  m = f->u.integer.m;

  n = extract_int (source, len);

  /* Special case:  */

  if (m == 0 && n == 0)
    {
      if (w == 0)
        w = 1;

      p = write_block (dtp, w);
      if (p == NULL)
        return;

      memset (p, ' ', w);
      goto done;
    }

  sign = calculate_sign (dtp, n < 0);
  if (n < 0)
    n = -n;

  nsign = sign == SIGN_NONE ? 0 : 1;
  q = conv (n, itoa_buf, sizeof (itoa_buf));

  digits = strlen (q);

  /* Select a width if none was specified.  The idea here is to always
     print something.  */

  if (w == 0)
    w = ((digits < m) ? m : digits) + nsign;

  p = write_block (dtp, w);
  if (p == NULL)
    return;

  nzero = 0;
  if (digits < m)
    nzero = m - digits;

  /* See if things will work.  */

  nblank = w - (nsign + nzero + digits);

  if (nblank < 0)
    {
      star_fill (p, w);
      goto done;
    }

  memset (p, ' ', nblank);
  p += nblank;

  switch (sign)
    {
    case SIGN_PLUS:
      *p++ = '+';
      break;
    case SIGN_MINUS:
      *p++ = '-';
      break;
    case SIGN_NONE:
      break;
    }

  memset (p, '0', nzero);
  p += nzero;

  memcpy (p, q, digits);

 done:
  return;
}


/* Convert unsigned octal to ascii.  */

static const char *
otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
{
  char *p;

  assert (len >= GFC_OTOA_BUF_SIZE);

  if (n == 0)
    return "0";

  p = buffer + GFC_OTOA_BUF_SIZE - 1;
  *p = '\0';

  while (n != 0)
    {
      *--p = '0' + (n & 7);
      n >>= 3;
    }

  return p;
}


/* Convert unsigned binary to ascii.  */

static const char *
btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
{
  char *p;

  assert (len >= GFC_BTOA_BUF_SIZE);

  if (n == 0)
    return "0";

  p = buffer + GFC_BTOA_BUF_SIZE - 1;
  *p = '\0';

  while (n != 0)
    {
      *--p = '0' + (n & 1);
      n >>= 1;
    }

  return p;
}


void
write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_decimal (dtp, f, p, len, (void *) gfc_itoa);
}


void
write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_int (dtp, f, p, len, btoa);
}


void
write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_int (dtp, f, p, len, otoa);
}

void
write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_int (dtp, f, p, len, xtoa);
}


void
write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_float (dtp, f, p, len);
}


void
write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_float (dtp, f, p, len);
}


void
write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_float (dtp, f, p, len);
}


void
write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_float (dtp, f, p, len);
}


void
write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
  write_float (dtp, f, p, len);
}


/* Take care of the X/TR descriptor.  */

void
write_x (st_parameter_dt *dtp, int len, int nspaces)
{
  char *p;

  p = write_block (dtp, len);
  if (p == NULL)
    return;

  if (nspaces > 0)
    memset (&p[len - nspaces], ' ', nspaces);
}


/* List-directed writing.  */


/* Write a single character to the output.  Returns nonzero if
   something goes wrong.  */

static int
write_char (st_parameter_dt *dtp, char c)
{
  char *p;