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   /* Padd 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           p = write_block (nb);
 776           if (nb < 3)
 777             {
 778               memset (p, '*',nb);
 779               return;
 780             }
 781
 782           memset(p, ' ', nb);
 783           res = !isnan (n);
 784           if (res != 0)
 785             {
 786               if (signbit(n))
 787                 fin = '-';
 788               else
 789                 fin = '+';
 790
 791               if (nb > 7)
 792                 memcpy(p + nb - 8, "Infinity", 8);
 793               else
 794                 memcpy(p + nb - 3, "Inf", 3);
 795               if (nb < 8 && nb > 3)
 796                 p[nb - 4] = fin;
 797               else if (nb > 8)
 798                 p[nb - 9] = fin;
 799             }
 800           else
 801             memcpy(p + nb - 3, "NaN", 3);
 802           return;
 803         }
 804     }
 805
 806   if (f->format != FMT_G)
 807     {
 808       output_float (f, n);
 809     }
 810   else
 811     {
 812       save_scale_factor = g.scale_factor;
 813       f2 = calculate_G_format(f, n, &nb);
 814       output_float (f2, n);
 815       g.scale_factor = save_scale_factor;
 816       if (f2 != NULL)
 817         free_mem(f2);
 818
 819       if (nb > 0)
 820         {
 821           p = write_block (nb);
 822           memset (p, ' ', nb);
 823         }
 824     }
 825 }
 826
 827
 828 static void
 829 write_int (fnode *f, const char *source, int len,
 830            char *(*conv) (GFC_UINTEGER_LARGEST))
 831 {
 832   GFC_UINTEGER_LARGEST n = 0;
 833   int w, m, digits, nzero, nblank;
 834   char *p, *q;
 835
 836   w = f->u.integer.w;
 837   m = f->u.integer.m;
 838
 839   n = extract_uint (source, len);
 840
 841   /* Special case:  */
 842
 843   if (m == 0 && n == 0)
 844     {
 845       if (w == 0)
 846         w = 1;
 847
 848       p = write_block (w);
 849       if (p == NULL)
 850         return;
 851
 852       memset (p, ' ', w);
 853       goto done;
 854     }
 855
 856   q = conv (n);
 857   digits = strlen (q);
 858
 859   /* Select a width if none was specified.  The idea here is to always
 860      print something.  */
 861
 862   if (w == 0)
 863     w = ((digits < m) ? m : digits);
 864
 865   p = write_block (w);
 866   if (p == NULL)
 867     return;
 868
 869   nzero = 0;
 870   if (digits < m)
 871     nzero = m - digits;
 872
 873   /* See if things will work.  */
 874
 875   nblank = w - (nzero + digits);
 876
 877   if (nblank < 0)
 878     {
 879       star_fill (p, w);
 880       goto done;
 881     }
 882
 883
 884   if (!no_leading_blank)
 885     {
 886   memset (p, ' ', nblank);
 887   p += nblank;
 888   memset (p, '0', nzero);
 889   p += nzero;
 890   memcpy (p, q, digits);
 891     }
 892   else
 893     {
 894       memset (p, '0', nzero);
 895       p += nzero;
 896       memcpy (p, q, digits);
 897       p += digits;
 898       memset (p, ' ', nblank);
 899       no_leading_blank = 0;
 900     }
 901
 902  done:
 903   return;
 904 }
 905
 906 static void
 907 write_decimal (fnode *f, const char *source, int len,
 908                char *(*conv) (GFC_INTEGER_LARGEST))
 909 {
 910   GFC_INTEGER_LARGEST n = 0;
 911   int w, m, digits, nsign, nzero, nblank;
 912   char *p, *q;
 913   sign_t sign;
 914
 915   w = f->u.integer.w;
 916   m = f->u.integer.m;
 917
 918   n = extract_int (source, len);
 919
 920   /* Special case:  */
 921
 922   if (m == 0 && n == 0)
 923     {
 924       if (w == 0)
 925         w = 1;
 926
 927       p = write_block (w);
 928       if (p == NULL)
 929         return;
 930
 931       memset (p, ' ', w);
 932       goto done;
 933     }
 934
 935   sign = calculate_sign (n < 0);
 936   if (n < 0)
 937     n = -n;
 938
 939   nsign = sign == SIGN_NONE ? 0 : 1;
 940   q = conv (n);
 941
 942   digits = strlen (q);
 943
 944   /* Select a width if none was specified.  The idea here is to always
 945      print something.  */
 946
 947   if (w == 0)
 948     w = ((digits < m) ? m : digits) + nsign;
 949
 950   p = write_block (w);
 951   if (p == NULL)
 952     return;
 953
 954   nzero = 0;
 955   if (digits < m)
 956     nzero = m - digits;
 957
 958   /* See if things will work.  */
 959
 960   nblank = w - (nsign + nzero + digits);
 961
 962   if (nblank < 0)
 963     {
 964       star_fill (p, w);
 965       goto done;
 966     }
 967
 968   memset (p, ' ', nblank);
 969   p += nblank;
 970
 971   switch (sign)
 972     {
 973     case SIGN_PLUS:
 974       *p++ = '+';
 975       break;
 976     case SIGN_MINUS:
 977       *p++ = '-';
 978       break;
 979     case SIGN_NONE:
 980       break;
 981     }
 982
 983   memset (p, '0', nzero);
 984   p += nzero;
 985
 986   memcpy (p, q, digits);
 987
 988  done:
 989   return;
 990 }
 991
 992
 993 /* Convert unsigned octal to ascii.  */
 994
 995 static char *
 996 otoa (GFC_UINTEGER_LARGEST n)
 997 {
 998   char *p;
 999
1000   if (n == 0)
1001     {
1002       scratch[0] = '0';
1003       scratch[1] = '\0';
1004       return scratch;
1005     }
1006
1007   p = scratch + SCRATCH_SIZE - 1;
1008   *p-- = '\0';
1009
1010   while (n != 0)
1011     {
1012       *p = '0' + (n & 7);
1013       p--;
1014       n >>= 3;
1015     }
1016
1017   return ++p;
1018 }
1019
1020
1021 /* Convert unsigned binary to ascii.  */
1022
1023 static char *
1024 btoa (GFC_UINTEGER_LARGEST n)
1025 {
1026   char *p;
1027
1028   if (n == 0)
1029     {
1030       scratch[0] = '0';
1031       scratch[1] = '\0';
1032       return scratch;
1033     }
1034
1035   p = scratch + SCRATCH_SIZE - 1;
1036   *p-- = '\0';
1037
1038   while (n != 0)
1039     {
1040       *p-- = '0' + (n & 1);
1041       n >>= 1;
1042     }
1043
1044   return ++p;
1045 }
1046
1047
1048 void
1049 write_i (fnode * f, const char *p, int len)
1050 {
1051   write_decimal (f, p, len, (void *) gfc_itoa);
1052 }
1053
1054
1055 void
1056 write_b (fnode * f, const char *p, int len)
1057 {
1058   write_int (f, p, len, btoa);
1059 }
1060
1061
1062 void
1063 write_o (fnode * f, const char *p, int len)
1064 {
1065   write_int (f, p, len, otoa);
1066 }
1067
1068 void
1069 write_z (fnode * f, const char *p, int len)
1070 {
1071   write_int (f, p, len, xtoa);
1072 }
1073
1074
1075 void
1076 write_d (fnode *f, const char *p, int len)
1077 {
1078   write_float (f, p, len);
1079 }
1080
1081
1082 void
1083 write_e (fnode *f, const char *p, int len)
1084 {
1085   write_float (f, p, len);
1086 }
1087
1088
1089 void
1090 write_f (fnode *f, const char *p, int len)
1091 {
1092   write_float (f, p, len);
1093 }
1094
1095
1096 void
1097 write_en (fnode *f, const char *p, int len)
1098 {
1099   write_float (f, p, len);
1100 }
1101
1102
1103 void
1104 write_es (fnode *f, const char *p, int len)
1105 {
1106   write_float (f, p, len);
1107 }
1108
1109
1110 /* Take care of the X/TR descriptor.  */
1111
1112 void
1113 write_x (fnode * f)
1114 {
1115   char *p;
1116
1117   p = write_block (f->u.n);
1118   if (p == NULL)
1119     return;
1120
1121   memset (p, ' ', f->u.n);
1122 }
1123
1124
1125 /* List-directed writing.  */
1126
1127
1128 /* Write a single character to the output.  Returns nonzero if
1129    something goes wrong.  */
1130
1131 static int
1132 write_char (char c)
1133 {
1134   char *p;
1135
1136   p = write_block (1);
1137   if (p == NULL)
1138     return 1;
1139
1140   *p = c;
1141
1142   return 0;
1143 }
1144
1145
1146 /* Write a list-directed logical value.  */
1147
1148 static void
1149 write_logical (const char *source, int length)
1150 {
1151   write_char (extract_int (source, length) ? 'T' : 'F');
1152 }
1153
1154
1155 /* Write a list-directed integer value.  */
1156
1157 static void
1158 write_integer (const char *source, int length)
1159 {
1160   char *p;
1161   const char *q;
1162   int digits;
1163   int width;
1164
1165   q = gfc_itoa (extract_int (source, length));
1166
1167   switch (length)
1168     {
1169     case 1:
1170       width = 4;
1171       break;
1172
1173     case 2:
1174       width = 6;
1175       break;
1176
1177     case 4:
1178       width = 11;
1179       break;
1180
1181     case 8:
1182       width = 20;
1183       break;
1184
1185     default:
1186       width = 0;
1187       break;
1188     }
1189
1190   digits = strlen (q);
1191
1192   if(width < digits )
1193     width = digits ;
1194   p = write_block (width) ;
1195   if (no_leading_blank)
1196     {
1197       memcpy (p, q, digits);
1198       memset(p + digits ,' ', width - digits) ;
1199     }
1200   else
1201     {
1202   memset(p ,' ', width - digits) ;
1203   memcpy (p + width - digits, q, digits);
1204     }
1205 }
1206
1207
1208 /* Write a list-directed string.  We have to worry about delimiting
1209    the strings if the file has been opened in that mode.  */
1210
1211 static void
1212 write_character (const char *source, int length)
1213 {
1214   int i, extra;
1215   char *p, d;
1216
1217   switch (current_unit->flags.delim)
1218     {
1219     case DELIM_APOSTROPHE:
1220       d = '\'';
1221       break;
1222     case DELIM_QUOTE:
1223       d = '"';
1224       break;
1225     default:
1226       d = ' ';
1227       break;
1228     }
1229
1230   if (d == ' ')
1231     extra = 0;
1232   else
1233     {
1234       extra = 2;
1235
1236       for (i = 0; i < length; i++)
1237         if (source[i] == d)
1238           extra++;
1239     }
1240
1241   p = write_block (length + extra);
1242   if (p == NULL)
1243     return;
1244
1245   if (d == ' ')
1246     memcpy (p, source, length);
1247   else
1248     {
1249       *p++ = d;
1250
1251       for (i = 0; i < length; i++)
1252         {
1253           *p++ = source[i];
1254           if (source[i] == d)
1255             *p++ = d;
1256         }
1257
1258       *p = d;
1259     }
1260 }
1261
1262
1263 /* Output a real number with default format.
1264    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1265
1266 static void
1267 write_real (const char *source, int length)
1268 {
1269   fnode f ;
1270   int org_scale = g.scale_factor;
1271   f.format = FMT_G;
1272   g.scale_factor = 1;
1273   if (length < 8)
1274     {
1275       f.u.real.w = 14;
1276       f.u.real.d = 7;
1277       f.u.real.e = 2;
1278     }
1279   else
1280     {
1281       f.u.real.w = 23;
1282       f.u.real.d = 15;
1283       f.u.real.e = 3;
1284     }
1285   write_float (&f, source , length);
1286   g.scale_factor = org_scale;
1287 }
1288
1289
1290 static void
1291 write_complex (const char *source, int len)
1292 {
1293   if (write_char ('('))
1294     return;
1295   write_real (source, len);
1296
1297   if (write_char (','))
1298     return;
1299   write_real (source + len, len);
1300
1301   write_char (')');
1302 }
1303
1304
1305 /* Write the separator between items.  */
1306
1307 static void
1308 write_separator (void)
1309 {
1310   char *p;
1311
1312   p = write_block (options.separator_len);
1313   if (p == NULL)
1314     return;
1315
1316   memcpy (p, options.separator, options.separator_len);
1317 }
1318
1319
1320 /* Write an item with list formatting.
1321    TODO: handle skipping to the next record correctly, particularly
1322    with strings.  */
1323
1324 void
1325 list_formatted_write (bt type, void *p, int len)
1326 {
1327   static int char_flag;
1328
1329   if (current_unit == NULL)
1330     return;
1331
1332   if (g.first_item)
1333     {
1334       g.first_item = 0;
1335       char_flag = 0;
1336       write_char (' ');
1337     }
1338   else
1339     {
1340       if (type != BT_CHARACTER || !char_flag ||
1341           current_unit->flags.delim != DELIM_NONE)
1342         write_separator ();
1343     }
1344
1345   switch (type)
1346     {
1347     case BT_INTEGER:
1348       write_integer (p, len);
1349       break;
1350     case BT_LOGICAL:
1351       write_logical (p, len);
1352       break;
1353     case BT_CHARACTER:
1354       write_character (p, len);
1355       break;
1356     case BT_REAL:
1357       write_real (p, len);
1358       break;
1359     case BT_COMPLEX:
1360       write_complex (p, len);
1361       break;
1362     default:
1363       internal_error ("list_formatted_write(): Bad type");
1364     }
1365
1366   char_flag = (type == BT_CHARACTER);
1367 }
1368
1369 /*                      NAMELIST OUTPUT
1370
1371    nml_write_obj writes a namelist object to the output stream.  It is called
1372    recursively for derived type components:
1373         obj    = is the namelist_info for the current object.
1374         offset = the offset relative to the address held by the object for
1375                  derived type arrays.
1376         base   = is the namelist_info of the derived type, when obj is a
1377                  component.
1378         base_name = the full name for a derived type, including qualifiers
1379                     if any.
1380    The returned value is a pointer to the object beyond the last one
1381    accessed, including nested derived types.  Notice that the namelist is
1382    a linear linked list of objects, including derived types and their
1383    components.  A tree, of sorts, is implied by the compound names of
1384    the derived type components and this is how this function recurses through
1385    the list.  */
1386
1387 /* A generous estimate of the number of characters needed to print
1388    repeat counts and indices, including commas, asterices and brackets.  */
1389
1390 #define NML_DIGITS 20
1391
1392 /* Stores the delimiter to be used for character objects.  */
1393
1394 static const char * nml_delim;
1395
1396 static namelist_info *
1397 nml_write_obj (namelist_info * obj, index_type offset,
1398                namelist_info * base, char * base_name)
1399 {
1400   int rep_ctr;
1401   int num;
1402   int nml_carry;
1403   index_type len;
1404   index_type obj_size;
1405   index_type nelem;
1406   index_type dim_i;
1407   index_type clen;
1408   index_type elem_ctr;
1409   index_type obj_name_len;
1410   void * p ;
1411   char cup;
1412   char * obj_name;
1413   char * ext_name;
1414   char rep_buff[NML_DIGITS];
1415   namelist_info * cmp;
1416   namelist_info * retval = obj->next;
1417
1418   /* Write namelist variable names in upper case. If a derived type,
1419      nothing is output.  If a component, base and base_name are set.  */
1420
1421   if (obj->type != GFC_DTYPE_DERIVED)
1422     {
1423       write_character ("\n ", 2);
1424       len = 0;
1425       if (base)
1426         {
1427           len =strlen (base->var_name);
1428           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1429             {
1430               cup = toupper (base_name[dim_i]);
1431               write_character (&cup, 1);
1432             }
1433         }
1434       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1435         {
1436           cup = toupper (obj->var_name[dim_i]);
1437           write_character (&cup, 1);
1438         }
1439       write_character ("=", 1);
1440     }
1441
1442   /* Counts the number of data output on a line, including names.  */
1443
1444   num = 1;
1445
1446   len = obj->len;
1447   obj_size = len;
1448   if (obj->type == GFC_DTYPE_COMPLEX)
1449     obj_size = 2*len;
1450   if (obj->type == GFC_DTYPE_CHARACTER)
1451     obj_size = obj->string_length;
1452   if (obj->var_rank)
1453     obj_size = obj->size;
1454
1455   /* Set the index vector and count the number of elements.  */
1456
1457   nelem = 1;
1458   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1459     {
1460       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1461       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1462     }
1463
1464   /* Main loop to output the data held in the object.  */
1465
1466   rep_ctr = 1;
1467   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1468     {
1469
1470       /* Build the pointer to the data value.  The offset is passed by
1471          recursive calls to this function for arrays of derived types.
1472          Is NULL otherwise.  */
1473
1474       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1475       p += offset;
1476
1477       /* Check for repeat counts of intrinsic types.  */
1478
1479       if ((elem_ctr < (nelem - 1)) &&
1480           (obj->type != GFC_DTYPE_DERIVED) &&
1481           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1482         {
1483           rep_ctr++;
1484         }
1485
1486       /* Execute a repeated output.  Note the flag no_leading_blank that
1487          is used in the functions used to output the intrinsic types.  */
1488
1489       else
1490         {
1491           if (rep_ctr > 1)
1492             {
1493               st_sprintf(rep_buff, " %d*", rep_ctr);
1494               write_character (rep_buff, strlen (rep_buff));
1495               no_leading_blank = 1;
1496             }
1497           num++;
1498
1499           /* Output the data, if an intrinsic type, or recurse into this
1500              routine to treat derived types.  */
1501
1502           switch (obj->type)
1503             {
1504
1505             case GFC_DTYPE_INTEGER:
1506               write_integer (p, len);
1507               break;
1508
1509             case GFC_DTYPE_LOGICAL:
1510               write_logical (p, len);
1511               break;
1512
1513             case GFC_DTYPE_CHARACTER:
1514               if (nml_delim)
1515                 write_character (nml_delim, 1);
1516               write_character (p, obj->string_length);
1517               if (nml_delim)
1518                 write_character (nml_delim, 1);
1519               break;
1520
1521             case GFC_DTYPE_REAL:
1522               write_real (p, len);
1523               break;
1524
1525             case GFC_DTYPE_COMPLEX:
1526               no_leading_blank = 0;
1527               num++;
1528               write_complex (p, len);
1529               break;
1530
1531             case GFC_DTYPE_DERIVED:
1532
1533               /* To treat a derived type, we need to build two strings:
1534                  ext_name = the name, including qualifiers that prepends
1535                             component names in the output - passed to
1536                             nml_write_obj.
1537                  obj_name = the derived type name with no qualifiers but %
1538                             appended.  This is used to identify the
1539                             components.  */
1540
1541               /* First ext_name => get length of all possible components  */
1542
1543               ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
1544                                         + (base ? strlen (base->var_name) : 0)
1545                                         + strlen (obj->var_name)
1546                                         + obj->var_rank * NML_DIGITS
1547                                         + 1);
1548
1549               strcpy(ext_name, base_name ? base_name : "");
1550               clen = base ? strlen (base->var_name) : 0;
1551               strcat (ext_name, obj->var_name + clen);
1552
1553               /* Append the qualifier.  */
1554
1555               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1556                 {
1557                   strcat (ext_name, dim_i ? "" : "(");
1558                   clen = strlen (ext_name);
1559                   st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
1560                   strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
1561                 }
1562
1563               /* Now obj_name.  */
1564
1565               obj_name_len = strlen (obj->var_name) + 1;
1566               obj_name = get_mem (obj_name_len+1);
1567               strcpy (obj_name, obj->var_name);
1568               strcat (obj_name, "%");
1569
1570               /* Now loop over the components. Update the component pointer
1571                  with the return value from nml_write_obj => this loop jumps
1572                  past nested derived types.  */
1573
1574               for (cmp = obj->next;
1575                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1576                    cmp = retval)
1577                 {
1578                   retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
1579                                           obj, ext_name);
1580                 }
1581
1582               free_mem (obj_name);
1583               free_mem (ext_name);
1584               goto obj_loop;
1585
1586             default:
1587               internal_error ("Bad type for namelist write");
1588             }
1589
1590           /* Reset the leading blank suppression, write a comma and, if 5
1591              values have been output, write a newline and advance to column
1592              2. Reset the repeat counter.  */
1593
1594           no_leading_blank = 0;
1595           write_character (",", 1);
1596           if (num > 5)
1597             {
1598               num = 0;
1599               write_character ("\n ", 2);
1600             }
1601           rep_ctr = 1;
1602         }
1603
1604     /* Cycle through and increment the index vector.  */
1605
1606 obj_loop:
1607
1608     nml_carry = 1;
1609     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1610       {
1611         obj->ls[dim_i].idx += nml_carry ;
1612         nml_carry = 0;
1613         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1614           {
1615             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1616             nml_carry = 1;
1617           }
1618        }
1619     }
1620
1621   /* Return a pointer beyond the furthest object accessed.  */
1622
1623   return retval;
1624 }
1625
1626 /* This is the entry function for namelist writes.  It outputs the name
1627    of the namelist and iterates through the namelist by calls to
1628    nml_write_obj.  The call below has dummys in the arguments used in
1629    the treatment of derived types.  */
1630
1631 void
1632 namelist_write (void)
1633 {
1634   namelist_info * t1, *t2, *dummy = NULL;
1635   index_type i;
1636   index_type dummy_offset = 0;
1637   char c;
1638   char * dummy_name = NULL;
1639   unit_delim tmp_delim;
1640
1641   /* Set the delimiter for namelist output.  */
1642
1643   tmp_delim = current_unit->flags.delim;
1644   current_unit->flags.delim = DELIM_NONE;
1645   switch (tmp_delim)
1646     {
1647     case (DELIM_QUOTE):
1648       nml_delim = "\"";
1649       break;
1650
1651     case (DELIM_APOSTROPHE):
1652       nml_delim = "'";
1653       break;
1654
1655     default:
1656       nml_delim = NULL;
1657     }
1658
1659   write_character ("&",1);
1660
1661   /* Write namelist name in upper case - f95 std.  */
1662
1663   for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
1664     {
1665       c = toupper (ioparm.namelist_name[i]);
1666       write_character (&c ,1);
1667             }
1668
1669   if (ionml != NULL)
1670     {
1671       t1 = ionml;
1672       while (t1 != NULL)
1673         {
1674           t2 = t1;
1675           t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
1676         }
1677     }
1678   write_character ("  /\n", 4);
1679
1680   /* Recover the original delimiter.  */
1681
1682   current_unit->flags.delim = tmp_delim;
1683 }
1684
1685 #undef NML_DIGITS