libgfortran/io/write.c

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