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