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