libgfortran/io/write.c

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