libgfortran/io/write.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with Libgfortran; see the file COPYING.  If not, write to
  27 the Free Software Foundation, 59 Temple Place - Suite 330,
  28 Boston, MA 02111-1307, USA.  */
  29
  30 #include "config.h"
  31 #include <string.h>
  32 #include <float.h>
  33 #include <stdio.h>
  34 #include <stdlib.h>
  35 #include "libgfortran.h"
  36 #include "io.h"
  37
  38
  39 #define star_fill(p, n) memset(p, '*', n)
  40
  41
  42 typedef enum
  43 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
  44 sign_t;
  45
  46
  47 void
  48 write_a (fnode * f, const char *source, int len)
  49 {
  50   int wlen;
  51   char *p;
  52
  53   wlen = f->u.string.length < 0 ? len : f->u.string.length;
  54
  55   p = write_block (wlen);
  56   if (p == NULL)
  57     return;
  58
  59   if (wlen < len)
  60     memcpy (p, source, wlen);
  61   else
  62     {
  63       memset (p, ' ', wlen - len);
  64       memcpy (p + wlen - len, source, len);
  65     }
  66 }
  67
  68 static int64_t
  69 extract_int (const void *p, int len)
  70 {
  71   int64_t i = 0;
  72
  73   if (p == NULL)
  74     return i;
  75
  76   switch (len)
  77     {
  78     case 1:
  79       i = *((const int8_t *) p);
  80       break;
  81     case 2:
  82       i = *((const int16_t *) p);
  83       break;
  84     case 4:
  85       i = *((const int32_t *) p);
  86       break;
  87     case 8:
  88       i = *((const int64_t *) p);
  89       break;
  90     default:
  91       internal_error ("bad integer kind");
  92     }
  93
  94   return i;
  95 }
  96
  97 static double
  98 extract_real (const void *p, int len)
  99 {
 100   double i = 0.0;
 101   switch (len)
 102     {
 103     case 4:
 104       i = *((const float *) p);
 105       break;
 106     case 8:
 107       i = *((const double *) p);
 108       break;
 109     default:
 110       internal_error ("bad real kind");
 111     }
 112   return i;
 113
 114 }
 115
 116
 117 /* Given a flag that indicate if a value is negative or not, return a
 118    sign_t that gives the sign that we need to produce.  */
 119
 120 static sign_t
 121 calculate_sign (int negative_flag)
 122 {
 123   sign_t s = SIGN_NONE;
 124
 125   if (negative_flag)
 126     s = SIGN_MINUS;
 127   else
 128     switch (g.sign_status)
 129       {
 130       case SIGN_SP:
 131         s = SIGN_PLUS;
 132         break;
 133       case SIGN_SS:
 134         s = SIGN_NONE;
 135         break;
 136       case SIGN_S:
 137         s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
 138         break;
 139       }
 140
 141   return s;
 142 }
 143
 144
 145 /* Returns the value of 10**d.  */
 146
 147 static double
 148 calculate_exp (int d)
 149 {
 150   int i;
 151   double r = 1.0;
 152
 153   for (i = 0; i< (d >= 0 ? d : -d); i++)
 154     r *= 10;
 155
 156   r = (d >= 0) ? r : 1.0 / r;
 157
 158   return r;
 159 }
 160
 161
 162 /* Generate corresponding I/O format for FMT_G output.
 163    The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
 164    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
 165
 166    Data Magnitude                              Equivalent Conversion
 167    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
 168    m = 0                                       F(w-n).(d-1), n' '
 169    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
 170    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
 171    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
 172    ................                           ..........
 173    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
 174    m >= 10**d-0.5                              Ew.d[Ee]
 175
 176    notes: for Gw.d ,  n' ' means 4 blanks
 177           for Gw.dEe, n' ' means e+2 blanks  */
 178
 179 static fnode *
 180 calculate_G_format (fnode *f, double value, int len, int *num_blank)
 181 {
 182   int e = f->u.real.e;
 183   int d = f->u.real.d;
 184   int w = f->u.real.w;
 185   fnode *newf;
 186   double m, exp_d;
 187   int low, high, mid;
 188   int ubound, lbound;
 189
 190   newf = get_mem (sizeof (fnode));
 191
 192   /* Absolute value.  */
 193   m = (value > 0.0) ? value : -value;
 194
 195   /* In case of the two data magnitude ranges,
 196      generate E editing, Ew.d[Ee].  */
 197   exp_d = calculate_exp (d);
 198   if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
 199       || (m >= (double) exp_d - 0.5 ))
 200     {
 201       newf->format = FMT_E;
 202       newf->u.real.w = w;
 203       newf->u.real.d = d;
 204       newf->u.real.e = e;
 205       *num_blank = 0;
 206       return newf;
 207     }
 208
 209   /* Use binary search to find the data magnitude range.  */
 210   mid = 0;
 211   low = 0;
 212   high = d + 1;
 213   lbound = 0;
 214   ubound = d + 1;
 215
 216   while (low <= high)
 217     {
 218       double temp;
 219       mid = (low + high) / 2;
 220
 221       /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
 222       temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
 223
 224       if (m < temp)
 225         {
 226           ubound = mid;
 227           if (ubound == lbound + 1)
 228             break;
 229           high = mid - 1;
 230         }
 231       else if (m > temp)
 232         {
 233           lbound = mid;
 234           if (ubound == lbound + 1)
 235             {
 236               mid ++;
 237               break;
 238             }
 239           low = mid + 1;
 240         }
 241       else
 242         break;
 243     }
 244
 245   /* Pad with blanks where the exponent would be.  */
 246   if (e < 0)
 247     *num_blank = 4;
 248   else
 249     *num_blank = e + 2;
 250
 251   /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '.  */
 252   newf->format = FMT_F;
 253   newf->u.real.w = f->u.real.w - *num_blank;
 254
 255   /* Special case.  */
 256   if (m == 0.0)
 257     newf->u.real.d = d - 1;
 258   else
 259     newf->u.real.d = - (mid - d - 1);
 260
 261   /* For F editing, the scale factor is ignored.  */
 262   g.scale_factor = 0;
 263   return newf;
 264 }
 265
 266
 267 /* Output a real number according to its format which is FMT_G free.  */
 268
 269 static void
 270 output_float (fnode *f, double value, int len)
 271 {
 272   /* This must be large enough to accurately hold any value.  */
 273   char buffer[32];
 274   char *out;
 275   char *digits;
 276   int e;
 277   char expchar;
 278   format_token ft;
 279   int w;
 280   int d;
 281   int edigits;
 282   int ndigits;
 283   /* Number of digits before the decimal point.  */
 284   int nbefore;
 285   /* Number of zeros after the decimal point.  */
 286   int nzero;
 287   /* Number of digits after the decimal point.  */
 288   int nafter;
 289   /* Number of zeros after the decimal point, whatever the precision.  */
 290   int nzero_real;
 291   int leadzero;
 292   int nblanks;
 293   int i;
 294   sign_t sign;
 295
 296   ft = f->format;
 297   w = f->u.real.w;
 298   d = f->u.real.d;
 299
 300   nzero_real = -1;
 301
 302
 303   /* We should always know the field width and precision.  */
 304   if (d < 0)
 305     internal_error ("Unspecified precision");
 306
 307   /* Use sprintf to print the number in the format +D.DDDDe+ddd
 308      For an N digit exponent, this gives us (32-6)-N digits after the
 309      decimal point, plus another one before the decimal point.  */
 310   sign = calculate_sign (value < 0.0);
 311   if (value < 0)
 312     value = -value;
 313
 314   /* Printf always prints at least two exponent digits.  */
 315   if (value == 0)
 316     edigits = 2;
 317   else
 318     {
 319       edigits = 1 + (int) log10 (fabs(log10 (value)));
 320       if (edigits < 2)
 321         edigits = 2;
 322     }
 323
 324   if (ft == FMT_F || ft == FMT_EN
 325       || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
 326     {
 327       /* Always convert at full precision to avoid double rounding.  */
 328       ndigits = 27 - edigits;
 329     }
 330   else
 331     {
 332       /* We know the number of digits, so can let printf do the rounding
 333          for us.  */
 334       if (ft == FMT_ES)
 335         ndigits = d + 1;
 336       else
 337         ndigits = d;
 338       if (ndigits > 27 - edigits)
 339         ndigits = 27 - edigits;
 340     }
 341
 342   sprintf (buffer, "%+-#31.*e", ndigits - 1, value);
 343
 344   /* Check the resulting string has punctuation in the correct places.  */
 345   if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
 346       internal_error ("printf is broken");
 347
 348   /* Read the exponent back in.  */
 349   e = atoi (&buffer[ndigits + 3]) + 1;
 350
 351   /* Make sure zero comes out as 0.0e0.  */
 352   if (value == 0.0)
 353     e = 0;
 354
 355   /* Normalize the fractional component.  */
 356   buffer[2] = buffer[1];
 357   digits = &buffer[2];
 358
 359   /* Figure out where to place the decimal point.  */
 360   switch (ft)
 361     {
 362     case FMT_F:
 363       nbefore = e + g.scale_factor;
 364       if (nbefore < 0)
 365         {
 366           nzero = -nbefore;
 367           nzero_real = nzero;
 368           if (nzero > d)
 369             nzero = d;
 370           nafter = d - nzero;
 371           nbefore = 0;
 372         }
 373       else
 374         {
 375           nzero = 0;
 376           nafter = d;
 377         }
 378       expchar = 0;
 379       break;
 380
 381     case FMT_E:
 382     case FMT_D:
 383       i = g.scale_factor;
 384       if (value != 0.0)
 385         e -= i;
 386       if (i < 0)
 387         {
 388           nbefore = 0;
 389           nzero = -i;
 390           nafter = d + i;
 391         }
 392       else if (i > 0)
 393         {
 394           nbefore = i;
 395           nzero = 0;
 396           nafter = (d - i) + 1;
 397         }
 398       else /* i == 0 */
 399         {
 400           nbefore = 0;
 401           nzero = 0;
 402           nafter = d;
 403         }
 404
 405       if (ft == FMT_E)
 406         expchar = 'E';
 407       else
 408         expchar = 'D';
 409       break;
 410
 411     case FMT_EN:
 412       /* The exponent must be a multiple of three, with 1-3 digits before
 413          the decimal point.  */
 414       if (value != 0.0)
 415         e--;
 416       if (e >= 0)
 417         nbefore = e % 3;
 418       else
 419         {
 420           nbefore = (-e) % 3;
 421           if (nbefore != 0)
 422             nbefore = 3 - nbefore;
 423         }
 424       e -= nbefore;
 425       nbefore++;
 426       nzero = 0;
 427       nafter = d;
 428       expchar = 'E';
 429       break;
 430
 431     case FMT_ES:
 432       if (value != 0.0)
 433         e--;
 434       nbefore = 1;
 435       nzero = 0;
 436       nafter = d;
 437       expchar = 'E';
 438       break;
 439
 440     default:
 441       /* Should never happen.  */
 442       internal_error ("Unexpected format token");
 443     }
 444
 445   /* Round the value.  */
 446   if (nbefore + nafter == 0)
 447     {
 448       ndigits = 0;
 449       if (nzero_real == d && digits[0] >= '5')
 450         {
 451           /* We rounded to zero but shouldn't have */
 452           nzero--;
 453           nafter = 1;
 454           digits[0] = '1';
 455           ndigits = 1;
 456         }
 457     }
 458   else if (nbefore + nafter < ndigits)
 459     {
 460       ndigits = nbefore + nafter;
 461       i = ndigits;
 462       if (digits[i] >= '5')
 463         {
 464           /* Propagate the carry.  */
 465           for (i--; i >= 0; i--)
 466             {
 467               if (digits[i] != '9')
 468                 {
 469                   digits[i]++;
 470                   break;
 471                 }
 472               digits[i] = '0';
 473             }
 474
 475           if (i < 0)
 476             {
 477               /* The carry overflowed.  Fortunately we have some spare space
 478                  at the start of the buffer.  We may discard some digits, but
 479                  this is ok because we already know they are zero.  */
 480               digits--;
 481               digits[0] = '1';
 482               if (ft == FMT_F)
 483                 {
 484                   if (nzero > 0)
 485                     {
 486                       nzero--;
 487                       nafter++;
 488                     }
 489                   else
 490                     nbefore++;
 491                 }
 492               else if (ft == FMT_EN)
 493                 {
 494                   nbefore++;
 495                   if (nbefore == 4)
 496                     {
 497                       nbefore = 1;
 498                       e += 3;
 499                     }
 500                 }
 501               else
 502                 e++;
 503             }
 504         }
 505     }
 506
 507   /* Calculate the format of the exponent field.  */
 508   if (expchar)
 509     {
 510       edigits = 1;
 511       for (i = abs (e); i >= 10; i /= 10)
 512         edigits++;
 513
 514       if (f->u.real.e < 0)
 515         {
 516           /* Width not specified.  Must be no more than 3 digits.  */
 517           if (e > 999 || e < -999)
 518             edigits = -1;
 519           else
 520             {
 521               edigits = 4;
 522               if (e > 99 || e < -99)
 523                 expchar = ' ';
 524             }
 525         }
 526       else
 527         {
 528           /* Exponent width specified, check it is wide enough.  */
 529           if (edigits > f->u.real.e)
 530             edigits = -1;
 531           else
 532             edigits = f->u.real.e + 2;
 533         }
 534     }
 535   else
 536     edigits = 0;
 537
 538   /* Pick a field size if none was specified.  */
 539   if (w <= 0)
 540     w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
 541
 542   /* Create the ouput buffer.  */
 543   out = write_block (w);
 544   if (out == NULL)
 545     return;
 546
 547   /* Zero values always output as positive, even if the value was negative
 548      before rounding.  */
 549   for (i = 0; i < ndigits; i++)
 550     {
 551       if (digits[i] != '0')
 552         break;
 553     }
 554   if (i == ndigits)
 555     sign = calculate_sign (0);
 556
 557   /* Work out how much padding is needed.  */
 558   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
 559   if (sign != SIGN_NONE)
 560     nblanks--;
 561
 562   /* Check the value fits in the specified field width.  */
 563   if (nblanks < 0 || edigits == -1)
 564     {
 565       star_fill (out, w);
 566       return;
 567     }
 568
 569   /* See if we have space for a zero before the decimal point.  */
 570   if (nbefore == 0 && nblanks > 0)
 571     {
 572       leadzero = 1;
 573       nblanks--;
 574     }
 575   else
 576     leadzero = 0;
 577
 578   /* Padd to full field width.  */
 579   if (nblanks > 0)
 580     {
 581       memset (out, ' ', nblanks);
 582       out += nblanks;
 583     }
 584
 585   /* Output the initial sign (if any).  */
 586   if (sign == SIGN_PLUS)
 587     *(out++) = '+';
 588   else if (sign == SIGN_MINUS)
 589     *(out++) = '-';
 590
 591   /* Output an optional leading zero.  */
 592   if (leadzero)
 593     *(out++) = '0';
 594
 595   /* Output the part before the decimal point, padding with zeros.  */
 596   if (nbefore > 0)
 597     {
 598       if (nbefore > ndigits)
 599         i = ndigits;
 600       else
 601         i = nbefore;
 602
 603       memcpy (out, digits, i);
 604       while (i < nbefore)
 605         out[i++] = '0';
 606
 607       digits += i;
 608       ndigits -= i;
 609       out += nbefore;
 610     }
 611   /* Output the decimal point.  */
 612   *(out++) = '.';
 613
 614   /* Output leading zeros after the decimal point.  */
 615   if (nzero > 0)
 616     {
 617       for (i = 0; i < nzero; i++)
 618         *(out++) = '0';
 619     }
 620
 621   /* Output digits after the decimal point, padding with zeros.  */
 622   if (nafter > 0)
 623     {
 624       if (nafter > ndigits)
 625         i = ndigits;
 626       else
 627         i = nafter;
 628
 629       memcpy (out, digits, i);
 630       while (i < nafter)
 631         out[i++] = '0';
 632
 633       digits += i;
 634       ndigits -= i;
 635       out += nafter;
 636     }
 637
 638   /* Output the exponent.  */
 639   if (expchar)
 640     {
 641       if (expchar != ' ')
 642         {
 643           *(out++) = expchar;
 644           edigits--;
 645         }
 646 #if HAVE_SNPRINTF
 647       snprintf (buffer, 32, "%+0*d", edigits, e);
 648 #else
 649       sprintf (buffer, "%+0*d", edigits, e);
 650 #endif
 651       memcpy (out, buffer, edigits);
 652     }
 653 }
 654
 655
 656 void
 657 write_l (fnode * f, char *source, int len)
 658 {
 659   char *p;
 660   int64_t n;
 661
 662   p = write_block (f->u.w);
 663   if (p == NULL)
 664     return;
 665
 666   memset (p, ' ', f->u.w - 1);
 667   n = extract_int (source, len);
 668   p[f->u.w - 1] = (n) ? 'T' : 'F';
 669 }
 670
 671 /* Output a real number according to its format.  */
 672
 673 static void
 674 write_float (fnode *f, const char *source, int len)
 675 {
 676   double n;
 677   int nb =0, res, save_scale_factor;
 678   char * p, fin;
 679   fnode *f2 = NULL;
 680
 681   n = extract_real (source, len);
 682
 683   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 684     {
 685       res = isfinite (n);
 686       if (res == 0)
 687         {
 688           nb =  f->u.real.w;
 689           p = write_block (nb);
 690           if (nb < 3)
 691             {
 692               memset (p, '*',nb);
 693               return;
 694             }
 695
 696           memset(p, ' ', nb);
 697           res = !isnan (n);
 698           if (res != 0)
 699             {
 700               if (signbit(n))
 701                 fin = '-';
 702               else
 703                 fin = '+';
 704
 705               if (nb > 7)
 706                 memcpy(p + nb - 8, "Infinity", 8);
 707               else
 708                 memcpy(p + nb - 3, "Inf", 3);
 709               if (nb < 8 && nb > 3)
 710                 p[nb - 4] = fin;
 711               else if (nb > 8)
 712                 p[nb - 9] = fin;
 713             }
 714           else
 715             memcpy(p + nb - 3, "NaN", 3);
 716           return;
 717         }
 718     }
 719
 720   if (f->format != FMT_G)
 721     {
 722       output_float (f, n, len);
 723     }
 724   else
 725     {
 726       save_scale_factor = g.scale_factor;
 727       f2 = calculate_G_format(f, n, len, &nb);
 728       output_float (f2, n, len);
 729       g.scale_factor = save_scale_factor;
 730       if (f2 != NULL)
 731         free_mem(f2);
 732
 733       if (nb > 0)
 734         {
 735           p = write_block (nb);
 736           memset (p, ' ', nb);
 737         }
 738     }
 739 }
 740
 741
 742 static void
 743 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 744 {
 745   uint32_t ns =0;
 746   uint64_t n = 0;
 747   int w, m, digits, nzero, nblank;
 748   char *p, *q;
 749
 750   w = f->u.integer.w;
 751   m = f->u.integer.m;
 752
 753   n = extract_int (source, len);
 754
 755   /* Special case:  */
 756
 757   if (m == 0 && n == 0)
 758     {
 759       if (w == 0)
 760         w = 1;
 761
 762       p = write_block (w);
 763       if (p == NULL)
 764         return;
 765
 766       memset (p, ' ', w);
 767       goto done;
 768     }
 769
 770
 771   if (len < 8)
 772      {
 773        ns = n;
 774        q = conv (ns);
 775      }
 776   else
 777       q = conv (n);
 778
 779   digits = strlen (q);
 780
 781   /* Select a width if none was specified.  The idea here is to always
 782      print something.  */
 783
 784   if (w == 0)
 785     w = ((digits < m) ? m : digits);
 786
 787   p = write_block (w);
 788   if (p == NULL)
 789     return;
 790
 791   nzero = 0;
 792   if (digits < m)
 793     nzero = m - digits;
 794
 795   /* See if things will work.  */
 796
 797   nblank = w - (nzero + digits);
 798
 799   if (nblank < 0)
 800     {
 801       star_fill (p, w);
 802       goto done;
 803     }
 804
 805   memset (p, ' ', nblank);
 806   p += nblank;
 807
 808   memset (p, '0', nzero);
 809   p += nzero;
 810
 811   memcpy (p, q, digits);
 812
 813  done:
 814   return;
 815 }
 816
 817 static void
 818 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 819 {
 820   int64_t n = 0;
 821   int w, m, digits, nsign, nzero, nblank;
 822   char *p, *q;
 823   sign_t sign;
 824
 825   w = f->u.integer.w;
 826   m = f->u.integer.m;
 827
 828   n = extract_int (source, len);
 829
 830   /* Special case:  */
 831
 832   if (m == 0 && n == 0)
 833     {
 834       if (w == 0)
 835         w = 1;
 836
 837       p = write_block (w);
 838       if (p == NULL)
 839         return;
 840
 841       memset (p, ' ', w);
 842       goto done;
 843     }
 844
 845   sign = calculate_sign (n < 0);
 846   if (n < 0)
 847     n = -n;
 848
 849   nsign = sign == SIGN_NONE ? 0 : 1;
 850   q = conv (n);
 851
 852   digits = strlen (q);
 853
 854   /* Select a width if none was specified.  The idea here is to always
 855      print something.  */
 856
 857   if (w == 0)
 858     w = ((digits < m) ? m : digits) + nsign;
 859
 860   p = write_block (w);
 861   if (p == NULL)
 862     return;
 863
 864   nzero = 0;
 865   if (digits < m)
 866     nzero = m - digits;
 867
 868   /* See if things will work.  */
 869
 870   nblank = w - (nsign + nzero + digits);
 871
 872   if (nblank < 0)
 873     {
 874       star_fill (p, w);
 875       goto done;
 876     }
 877
 878   memset (p, ' ', nblank);
 879   p += nblank;
 880
 881   switch (sign)
 882     {
 883     case SIGN_PLUS:
 884       *p++ = '+';
 885       break;
 886     case SIGN_MINUS:
 887       *p++ = '-';
 888       break;
 889     case SIGN_NONE:
 890       break;
 891     }
 892
 893   memset (p, '0', nzero);
 894   p += nzero;
 895
 896   memcpy (p, q, digits);
 897
 898  done:
 899   return;
 900 }
 901
 902
 903 /* Convert unsigned octal to ascii.  */
 904
 905 static char *
 906 otoa (uint64_t n)
 907 {
 908   char *p;
 909
 910   if (n == 0)
 911     {
 912       scratch[0] = '0';
 913       scratch[1] = '\0';
 914       return scratch;
 915     }
 916
 917   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 918   *p-- = '\0';
 919
 920   while (n != 0)
 921     {
 922       *p = '0' + (n & 7);
 923       p -- ;
 924       n >>= 3;
 925     }
 926
 927   return ++p;
 928 }
 929
 930
 931 /* Convert unsigned binary to ascii.  */
 932
 933 static char *
 934 btoa (uint64_t n)
 935 {
 936   char *p;
 937
 938   if (n == 0)
 939     {
 940       scratch[0] = '0';
 941       scratch[1] = '\0';
 942       return scratch;
 943     }
 944
 945   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 946   *p-- = '\0';
 947
 948   while (n != 0)
 949     {
 950       *p-- = '0' + (n & 1);
 951       n >>= 1;
 952     }
 953
 954   return ++p;
 955 }
 956
 957
 958 void
 959 write_i (fnode * f, const char *p, int len)
 960 {
 961   write_decimal (f, p, len, (void *) gfc_itoa);
 962 }
 963
 964
 965 void
 966 write_b (fnode * f, const char *p, int len)
 967 {
 968   write_int (f, p, len, btoa);
 969 }
 970
 971
 972 void
 973 write_o (fnode * f, const char *p, int len)
 974 {
 975   write_int (f, p, len, otoa);
 976 }
 977
 978 void
 979 write_z (fnode * f, const char *p, int len)
 980 {
 981   write_int (f, p, len, xtoa);
 982 }
 983
 984
 985 void
 986 write_d (fnode *f, const char *p, int len)
 987 {
 988   write_float (f, p, len);
 989 }
 990
 991
 992 void
 993 write_e (fnode *f, const char *p, int len)
 994 {
 995   write_float (f, p, len);
 996 }
 997
 998
 999 void
1000 write_f (fnode *f, const char *p, int len)
1001 {
1002   write_float (f, p, len);
1003 }
1004
1005
1006 void
1007 write_en (fnode *f, const char *p, int len)
1008 {
1009   write_float (f, p, len);
1010 }
1011
1012
1013 void
1014 write_es (fnode *f, const char *p, int len)
1015 {
1016   write_float (f, p, len);
1017 }
1018
1019
1020 /* Take care of the X/TR descriptor.  */
1021
1022 void
1023 write_x (fnode * f)
1024 {
1025   char *p;
1026
1027   p = write_block (f->u.n);
1028   if (p == NULL)
1029     return;
1030
1031   memset (p, ' ', f->u.n);
1032 }
1033
1034
1035 /* List-directed writing.  */
1036
1037
1038 /* Write a single character to the output.  Returns nonzero if
1039    something goes wrong.  */
1040
1041 static int
1042 write_char (char c)
1043 {
1044   char *p;
1045
1046   p = write_block (1);
1047   if (p == NULL)
1048     return 1;
1049
1050   *p = c;
1051
1052   return 0;
1053 }
1054
1055
1056 /* Write a list-directed logical value.  */
1057
1058 static void
1059 write_logical (const char *source, int length)
1060 {
1061   write_char (extract_int (source, length) ? 'T' : 'F');
1062 }
1063
1064
1065 /* Write a list-directed integer value.  */
1066
1067 static void
1068 write_integer (const char *source, int length)
1069 {
1070   char *p;
1071   const char *q;
1072   int digits;
1073   int width;
1074
1075   q = gfc_itoa (extract_int (source, length));
1076
1077   switch (length)
1078     {
1079     case 1:
1080       width = 4;
1081       break;
1082
1083     case 2:
1084       width = 6;
1085       break;
1086
1087     case 4:
1088       width = 11;
1089       break;
1090
1091     case 8:
1092       width = 20;
1093       break;
1094
1095     default:
1096       width = 0;
1097       break;
1098     }
1099
1100   digits = strlen (q);
1101
1102   if(width < digits )
1103     width = digits ;
1104   p = write_block (width) ;
1105
1106   memset(p ,' ', width - digits) ;
1107   memcpy (p + width - digits, q, digits);
1108 }
1109
1110
1111 /* Write a list-directed string.  We have to worry about delimiting
1112    the strings if the file has been opened in that mode.  */
1113
1114 static void
1115 write_character (const char *source, int length)
1116 {
1117   int i, extra;
1118   char *p, d;
1119
1120   switch (current_unit->flags.delim)
1121     {
1122     case DELIM_APOSTROPHE:
1123       d = '\'';
1124       break;
1125     case DELIM_QUOTE:
1126       d = '"';
1127       break;
1128     default:
1129       d = ' ';
1130       break;
1131     }
1132
1133   if (d == ' ')
1134     extra = 0;
1135   else
1136     {
1137       extra = 2;
1138
1139       for (i = 0; i < length; i++)
1140         if (source[i] == d)
1141           extra++;
1142     }
1143
1144   p = write_block (length + extra);
1145   if (p == NULL)
1146     return;
1147
1148   if (d == ' ')
1149     memcpy (p, source, length);
1150   else
1151     {
1152       *p++ = d;
1153
1154       for (i = 0; i < length; i++)
1155         {
1156           *p++ = source[i];
1157           if (source[i] == d)
1158             *p++ = d;
1159         }
1160
1161       *p = d;
1162     }
1163 }
1164
1165
1166 /* Output a real number with default format.
1167    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1168
1169 static void
1170 write_real (const char *source, int length)
1171 {
1172   fnode f ;
1173   int org_scale = g.scale_factor;
1174   f.format = FMT_G;
1175   g.scale_factor = 1;
1176   if (length < 8)
1177     {
1178       f.u.real.w = 14;
1179       f.u.real.d = 7;
1180       f.u.real.e = 2;
1181     }
1182   else
1183     {
1184       f.u.real.w = 23;
1185       f.u.real.d = 15;
1186       f.u.real.e = 3;
1187     }
1188   write_float (&f, source , length);
1189   g.scale_factor = org_scale;
1190 }
1191
1192
1193 static void
1194 write_complex (const char *source, int len)
1195 {
1196   if (write_char ('('))
1197     return;
1198   write_real (source, len);
1199
1200   if (write_char (','))
1201     return;
1202   write_real (source + len, len);
1203
1204   write_char (')');
1205 }
1206
1207
1208 /* Write the separator between items.  */
1209
1210 static void
1211 write_separator (void)
1212 {
1213   char *p;
1214
1215   p = write_block (options.separator_len);
1216   if (p == NULL)
1217     return;
1218
1219   memcpy (p, options.separator, options.separator_len);
1220 }
1221
1222
1223 /* Write an item with list formatting.
1224    TODO: handle skipping to the next record correctly, particularly
1225    with strings.  */
1226
1227 void
1228 list_formatted_write (bt type, void *p, int len)
1229 {
1230   static int char_flag;
1231
1232   if (current_unit == NULL)
1233     return;
1234
1235   if (g.first_item)
1236     {
1237       g.first_item = 0;
1238       char_flag = 0;
1239       write_char (' ');
1240     }
1241   else
1242     {
1243       if (type != BT_CHARACTER || !char_flag ||
1244           current_unit->flags.delim != DELIM_NONE)
1245         write_separator ();
1246     }
1247
1248   switch (type)
1249     {
1250     case BT_INTEGER:
1251       write_integer (p, len);
1252       break;
1253     case BT_LOGICAL:
1254       write_logical (p, len);
1255       break;
1256     case BT_CHARACTER:
1257       write_character (p, len);
1258       break;
1259     case BT_REAL:
1260       write_real (p, len);
1261       break;
1262     case BT_COMPLEX:
1263       write_complex (p, len);
1264       break;
1265     default:
1266       internal_error ("list_formatted_write(): Bad type");
1267     }
1268
1269   char_flag = (type == BT_CHARACTER);
1270 }
1271
1272 void
1273 namelist_write (void)
1274 {
1275   namelist_info * t1, *t2;
1276   int len,num;
1277   void * p;
1278
1279   num = 0;
1280   write_character("&",1);
1281   write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1282   write_character("\n",1);
1283
1284   if (ionml != NULL)
1285     {
1286       t1 = ionml;
1287       while (t1 != NULL)
1288         {
1289           num ++;
1290           t2 = t1;
1291           t1 = t1->next;
1292           if (t2->var_name)
1293             {
1294               write_character(t2->var_name, strlen(t2->var_name));
1295               write_character("=",1);
1296             }
1297           len = t2->len;
1298           p = t2->mem_pos;
1299           switch (t2->type)
1300             {
1301             case BT_INTEGER:
1302               write_integer (p, len);
1303               break;
1304             case BT_LOGICAL:
1305               write_logical (p, len);
1306               break;
1307             case BT_CHARACTER:
1308               write_character (p, t2->string_length);
1309               break;
1310             case BT_REAL:
1311               write_real (p, len);
1312               break;
1313             case BT_COMPLEX:
1314               write_complex (p, len);
1315               break;
1316             default:
1317               internal_error ("Bad type for namelist write");
1318             }
1319           write_character(",",1);
1320           if (num > 5)
1321             {
1322               num = 0;
1323               write_character("\n",1);
1324             }
1325         }
1326     }
1327   write_character("/",1);
1328 }