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