libgfortran/io/write.c

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