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;
 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       f2 = calculate_G_format(f, n, len, &nb);
 727       output_float (f2, n, len);
 728       if (f2 != NULL)
 729         free_mem(f2);
 730
 731       if (nb > 0)
 732         {
 733           p = write_block (nb);
 734           memset (p, ' ', nb);
 735         }
 736     }
 737 }
 738
 739
 740 static void
 741 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 742 {
 743   uint32_t ns =0;
 744   uint64_t n = 0;
 745   int w, m, digits, nzero, nblank;
 746   char *p, *q;
 747
 748   w = f->u.integer.w;
 749   m = f->u.integer.m;
 750
 751   n = extract_int (source, len);
 752
 753   /* Special case:  */
 754
 755   if (m == 0 && n == 0)
 756     {
 757       if (w == 0)
 758         w = 1;
 759
 760       p = write_block (w);
 761       if (p == NULL)
 762         return;
 763
 764       memset (p, ' ', w);
 765       goto done;
 766     }
 767
 768
 769   if (len < 8)
 770      {
 771        ns = n;
 772        q = conv (ns);
 773      }
 774   else
 775       q = conv (n);
 776
 777   digits = strlen (q);
 778
 779   /* Select a width if none was specified.  The idea here is to always
 780      print something.  */
 781
 782   if (w == 0)
 783     w = ((digits < m) ? m : digits);
 784
 785   p = write_block (w);
 786   if (p == NULL)
 787     return;
 788
 789   nzero = 0;
 790   if (digits < m)
 791     nzero = m - digits;
 792
 793   /* See if things will work.  */
 794
 795   nblank = w - (nzero + digits);
 796
 797   if (nblank < 0)
 798     {
 799       star_fill (p, w);
 800       goto done;
 801     }
 802
 803   memset (p, ' ', nblank);
 804   p += nblank;
 805
 806   memset (p, '0', nzero);
 807   p += nzero;
 808
 809   memcpy (p, q, digits);
 810
 811  done:
 812   return;
 813 }
 814
 815 static void
 816 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 817 {
 818   int64_t n = 0;
 819   int w, m, digits, nsign, nzero, nblank;
 820   char *p, *q;
 821   sign_t sign;
 822
 823   w = f->u.integer.w;
 824   m = f->u.integer.m;
 825
 826   n = extract_int (source, len);
 827
 828   /* Special case:  */
 829
 830   if (m == 0 && n == 0)
 831     {
 832       if (w == 0)
 833         w = 1;
 834
 835       p = write_block (w);
 836       if (p == NULL)
 837         return;
 838
 839       memset (p, ' ', w);
 840       goto done;
 841     }
 842
 843   sign = calculate_sign (n < 0);
 844   if (n < 0)
 845     n = -n;
 846
 847   nsign = sign == SIGN_NONE ? 0 : 1;
 848   q = conv (n);
 849
 850   digits = strlen (q);
 851
 852   /* Select a width if none was specified.  The idea here is to always
 853      print something.  */
 854
 855   if (w == 0)
 856     w = ((digits < m) ? m : digits) + nsign;
 857
 858   p = write_block (w);
 859   if (p == NULL)
 860     return;
 861
 862   nzero = 0;
 863   if (digits < m)
 864     nzero = m - digits;
 865
 866   /* See if things will work.  */
 867
 868   nblank = w - (nsign + nzero + digits);
 869
 870   if (nblank < 0)
 871     {
 872       star_fill (p, w);
 873       goto done;
 874     }
 875
 876   memset (p, ' ', nblank);
 877   p += nblank;
 878
 879   switch (sign)
 880     {
 881     case SIGN_PLUS:
 882       *p++ = '+';
 883       break;
 884     case SIGN_MINUS:
 885       *p++ = '-';
 886       break;
 887     case SIGN_NONE:
 888       break;
 889     }
 890
 891   memset (p, '0', nzero);
 892   p += nzero;
 893
 894   memcpy (p, q, digits);
 895
 896  done:
 897   return;
 898 }
 899
 900
 901 /* Convert unsigned octal to ascii.  */
 902
 903 static char *
 904 otoa (uint64_t n)
 905 {
 906   char *p;
 907
 908   if (n == 0)
 909     {
 910       scratch[0] = '0';
 911       scratch[1] = '\0';
 912       return scratch;
 913     }
 914
 915   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 916   *p-- = '\0';
 917
 918   while (n != 0)
 919     {
 920       *p = '0' + (n & 7);
 921       p -- ;
 922       n >>= 3;
 923     }
 924
 925   return ++p;
 926 }
 927
 928
 929 /* Convert unsigned binary to ascii.  */
 930
 931 static char *
 932 btoa (uint64_t n)
 933 {
 934   char *p;
 935
 936   if (n == 0)
 937     {
 938       scratch[0] = '0';
 939       scratch[1] = '\0';
 940       return scratch;
 941     }
 942
 943   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 944   *p-- = '\0';
 945
 946   while (n != 0)
 947     {
 948       *p-- = '0' + (n & 1);
 949       n >>= 1;
 950     }
 951
 952   return ++p;
 953 }
 954
 955
 956 void
 957 write_i (fnode * f, const char *p, int len)
 958 {
 959   write_decimal (f, p, len, (void *) gfc_itoa);
 960 }
 961
 962
 963 void
 964 write_b (fnode * f, const char *p, int len)
 965 {
 966   write_int (f, p, len, btoa);
 967 }
 968
 969
 970 void
 971 write_o (fnode * f, const char *p, int len)
 972 {
 973   write_int (f, p, len, otoa);
 974 }
 975
 976 void
 977 write_z (fnode * f, const char *p, int len)
 978 {
 979   write_int (f, p, len, xtoa);
 980 }
 981
 982
 983 void
 984 write_d (fnode *f, const char *p, int len)
 985 {
 986   write_float (f, p, len);
 987 }
 988
 989
 990 void
 991 write_e (fnode *f, const char *p, int len)
 992 {
 993   write_float (f, p, len);
 994 }
 995
 996
 997 void
 998 write_f (fnode *f, const char *p, int len)
 999 {
1000   write_float (f, p, len);
1001 }
1002
1003
1004 void
1005 write_en (fnode *f, const char *p, int len)
1006 {
1007   write_float (f, p, len);
1008 }
1009
1010
1011 void
1012 write_es (fnode *f, const char *p, int len)
1013 {
1014   write_float (f, p, len);
1015 }
1016
1017
1018 /* Take care of the X/TR descriptor.  */
1019
1020 void
1021 write_x (fnode * f)
1022 {
1023   char *p;
1024
1025   p = write_block (f->u.n);
1026   if (p == NULL)
1027     return;
1028
1029   memset (p, ' ', f->u.n);
1030 }
1031
1032
1033 /* List-directed writing.  */
1034
1035
1036 /* Write a single character to the output.  Returns nonzero if
1037    something goes wrong.  */
1038
1039 static int
1040 write_char (char c)
1041 {
1042   char *p;
1043
1044   p = write_block (1);
1045   if (p == NULL)
1046     return 1;
1047
1048   *p = c;
1049
1050   return 0;
1051 }
1052
1053
1054 /* Write a list-directed logical value.  */
1055
1056 static void
1057 write_logical (const char *source, int length)
1058 {
1059   write_char (extract_int (source, length) ? 'T' : 'F');
1060 }
1061
1062
1063 /* Write a list-directed integer value.  */
1064
1065 static void
1066 write_integer (const char *source, int length)
1067 {
1068   char *p;
1069   const char *q;
1070   int digits;
1071   int width;
1072
1073   q = gfc_itoa (extract_int (source, length));
1074
1075   switch (length)
1076     {
1077     case 1:
1078       width = 4;
1079       break;
1080
1081     case 2:
1082       width = 6;
1083       break;
1084
1085     case 4:
1086       width = 11;
1087       break;
1088
1089     case 8:
1090       width = 20;
1091       break;
1092
1093     default:
1094       width = 0;
1095       break;
1096     }
1097
1098   digits = strlen (q);
1099
1100   if(width < digits )
1101     width = digits ;
1102   p = write_block (width) ;
1103
1104   memset(p ,' ', width - digits) ;
1105   memcpy (p + width - digits, q, digits);
1106 }
1107
1108
1109 /* Write a list-directed string.  We have to worry about delimiting
1110    the strings if the file has been opened in that mode.  */
1111
1112 static void
1113 write_character (const char *source, int length)
1114 {
1115   int i, extra;
1116   char *p, d;
1117
1118   switch (current_unit->flags.delim)
1119     {
1120     case DELIM_APOSTROPHE:
1121       d = '\'';
1122       break;
1123     case DELIM_QUOTE:
1124       d = '"';
1125       break;
1126     default:
1127       d = ' ';
1128       break;
1129     }
1130
1131   if (d == ' ')
1132     extra = 0;
1133   else
1134     {
1135       extra = 2;
1136
1137       for (i = 0; i < length; i++)
1138         if (source[i] == d)
1139           extra++;
1140     }
1141
1142   p = write_block (length + extra);
1143   if (p == NULL)
1144     return;
1145
1146   if (d == ' ')
1147     memcpy (p, source, length);
1148   else
1149     {
1150       *p++ = d;
1151
1152       for (i = 0; i < length; i++)
1153         {
1154           *p++ = source[i];
1155           if (source[i] == d)
1156             *p++ = d;
1157         }
1158
1159       *p = d;
1160     }
1161 }
1162
1163
1164 /* Output a real number with default format.
1165    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1166
1167 static void
1168 write_real (const char *source, int length)
1169 {
1170   fnode f ;
1171   int org_scale = g.scale_factor;
1172   f.format = FMT_G;
1173   g.scale_factor = 1;
1174   if (length < 8)
1175     {
1176       f.u.real.w = 14;
1177       f.u.real.d = 7;
1178       f.u.real.e = 2;
1179     }
1180   else
1181     {
1182       f.u.real.w = 23;
1183       f.u.real.d = 15;
1184       f.u.real.e = 3;
1185     }
1186   write_float (&f, source , length);
1187   g.scale_factor = org_scale;
1188 }
1189
1190
1191 static void
1192 write_complex (const char *source, int len)
1193 {
1194   if (write_char ('('))
1195     return;
1196   write_real (source, len);
1197
1198   if (write_char (','))
1199     return;
1200   write_real (source + len, len);
1201
1202   write_char (')');
1203 }
1204
1205
1206 /* Write the separator between items.  */
1207
1208 static void
1209 write_separator (void)
1210 {
1211   char *p;
1212
1213   p = write_block (options.separator_len);
1214   if (p == NULL)
1215     return;
1216
1217   memcpy (p, options.separator, options.separator_len);
1218 }
1219
1220
1221 /* Write an item with list formatting.
1222    TODO: handle skipping to the next record correctly, particularly
1223    with strings.  */
1224
1225 void
1226 list_formatted_write (bt type, void *p, int len)
1227 {
1228   static int char_flag;
1229
1230   if (current_unit == NULL)
1231     return;
1232
1233   if (g.first_item)
1234     {
1235       g.first_item = 0;
1236       char_flag = 0;
1237       write_char (' ');
1238     }
1239   else
1240     {
1241       if (type != BT_CHARACTER || !char_flag ||
1242           current_unit->flags.delim != DELIM_NONE)
1243         write_separator ();
1244     }
1245
1246   switch (type)
1247     {
1248     case BT_INTEGER:
1249       write_integer (p, len);
1250       break;
1251     case BT_LOGICAL:
1252       write_logical (p, len);
1253       break;
1254     case BT_CHARACTER:
1255       write_character (p, len);
1256       break;
1257     case BT_REAL:
1258       write_real (p, len);
1259       break;
1260     case BT_COMPLEX:
1261       write_complex (p, len);
1262       break;
1263     default:
1264       internal_error ("list_formatted_write(): Bad type");
1265     }
1266
1267   char_flag = (type == BT_CHARACTER);
1268 }
1269
1270 void
1271 namelist_write (void)
1272 {
1273   namelist_info * t1, *t2;
1274   int len,num;
1275   void * p;
1276
1277   num = 0;
1278   write_character("&",1);
1279   write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1280   write_character("\n",1);
1281
1282   if (ionml != NULL)
1283     {
1284       t1 = ionml;
1285       while (t1 != NULL)
1286         {
1287           num ++;
1288           t2 = t1;
1289           t1 = t1->next;
1290           if (t2->var_name)
1291             {
1292               write_character(t2->var_name, strlen(t2->var_name));
1293               write_character("=",1);
1294             }
1295           len = t2->len;
1296           p = t2->mem_pos;
1297           switch (t2->type)
1298             {
1299             case BT_INTEGER:
1300               write_integer (p, len);
1301               break;
1302             case BT_LOGICAL:
1303               write_logical (p, len);
1304               break;
1305             case BT_CHARACTER:
1306               write_character (p, t2->string_length);
1307               break;
1308             case BT_REAL:
1309               write_real (p, len);
1310               break;
1311             case BT_COMPLEX:
1312               write_complex (p, len);
1313               break;
1314             default:
1315               internal_error ("Bad type for namelist write");
1316             }
1317           write_character(",",1);
1318           if (num > 5)
1319             {
1320               num = 0;
1321               write_character("\n",1);
1322             }
1323         }
1324     }
1325   write_character("/",1);
1326 }