libgfortran/io/write.c

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