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