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   int sign_bit;
 469   sign_t sign;
 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   sign_bit = signbit (value);
 487   if (value < 0)
 488     value = -value;
 489
 490   /* Special case when format specifies no digits after the decimal point.  */
 491   if (d == 0 && ft == FMT_F)
 492     {
 493       if (value < 0.5)
 494         value = 0.0;
 495       else if (value < 1.0)
 496         value = value + 0.5;
 497     }
 498
 499   /* printf pads blanks for us on the exponent so we just need it big enough
 500      to handle the largest number of exponent digits expected.  */
 501   edigits=4;
 502
 503   if (ft == FMT_F || ft == FMT_EN
 504       || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
 505     {
 506       /* Always convert at full precision to avoid double rounding.  */
 507       ndigits = MIN_FIELD_WIDTH - 4 - edigits;
 508     }
 509   else
 510     {
 511       /* We know the number of digits, so can let printf do the rounding
 512          for us.  */
 513       if (ft == FMT_ES)
 514         ndigits = d + 1;
 515       else
 516         ndigits = d;
 517       if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
 518         ndigits = MIN_FIELD_WIDTH - 4 - edigits;
 519     }
 520
 521   /* #   The result will always contain a decimal point, even if no
 522    *     digits follow it
 523    *
 524    * -   The converted value is to be left adjusted on the field boundary
 525    *
 526    * +   A sign (+ or -) always be placed before a number
 527    *
 528    * MIN_FIELD_WIDTH  minimum field width
 529    *
 530    * *   (ndigits-1) is used as the precision
 531    *
 532    *   e format: [-]d.ddde±dd where there is one digit before the
 533    *   decimal-point character and the number of digits after it is
 534    *   equal to the precision. The exponent always contains at least two
 535    *   digits; if the value is zero, the exponent is 00.
 536    */
 537 #ifdef HAVE_SNPRINTF
 538   snprintf (buffer, sizeof (buffer), "%+-#" STR(MIN_FIELD_WIDTH) ".*"
 539            GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
 540 #else
 541   sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*"
 542            GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
 543 #endif
 544
 545   /* Check the resulting string has punctuation in the correct places.  */
 546   if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e'))
 547       internal_error (&dtp->common, "printf is broken");
 548
 549   /* Read the exponent back in.  */
 550   e = atoi (&buffer[ndigits + 3]) + 1;
 551
 552   /* Make sure zero comes out as 0.0e0.   */
 553   if (value == 0.0)
 554     {
 555       e = 0;
 556       if (compile_options.sign_zero == 1)
 557         sign = calculate_sign (dtp, sign_bit);
 558       else
 559         sign = calculate_sign (dtp, 0);
 560     }
 561
 562   /* Normalize the fractional component.  */
 563   buffer[2] = buffer[1];
 564   digits = &buffer[2];
 565
 566   /* Figure out where to place the decimal point.  */
 567   switch (ft)
 568     {
 569     case FMT_F:
 570       nbefore = e + dtp->u.p.scale_factor;
 571       if (nbefore < 0)
 572         {
 573           nzero = -nbefore;
 574           nzero_real = nzero;
 575           if (nzero > d)
 576             nzero = d;
 577           nafter = d - nzero;
 578           nbefore = 0;
 579         }
 580       else
 581         {
 582           nzero = 0;
 583           nafter = d;
 584         }
 585       expchar = 0;
 586       break;
 587
 588     case FMT_E:
 589     case FMT_D:
 590       i = dtp->u.p.scale_factor;
 591       if (value != 0.0)
 592         e -= i;
 593       if (i < 0)
 594         {
 595           nbefore = 0;
 596           nzero = -i;
 597           nafter = d + i;
 598         }
 599       else if (i > 0)
 600         {
 601           nbefore = i;
 602           nzero = 0;
 603           nafter = (d - i) + 1;
 604         }
 605       else /* i == 0 */
 606         {
 607           nbefore = 0;
 608           nzero = 0;
 609           nafter = d;
 610         }
 611
 612       if (ft == FMT_E)
 613         expchar = 'E';
 614       else
 615         expchar = 'D';
 616       break;
 617
 618     case FMT_EN:
 619       /* The exponent must be a multiple of three, with 1-3 digits before
 620          the decimal point.  */
 621       if (value != 0.0)
 622         e--;
 623       if (e >= 0)
 624         nbefore = e % 3;
 625       else
 626         {
 627           nbefore = (-e) % 3;
 628           if (nbefore != 0)
 629             nbefore = 3 - nbefore;
 630         }
 631       e -= nbefore;
 632       nbefore++;
 633       nzero = 0;
 634       nafter = d;
 635       expchar = 'E';
 636       break;
 637
 638     case FMT_ES:
 639       if (value != 0.0)
 640         e--;
 641       nbefore = 1;
 642       nzero = 0;
 643       nafter = d;
 644       expchar = 'E';
 645       break;
 646
 647     default:
 648       /* Should never happen.  */
 649       internal_error (&dtp->common, "Unexpected format token");
 650     }
 651
 652   /* Round the value.  */
 653   if (nbefore + nafter == 0)
 654     {
 655       ndigits = 0;
 656       if (nzero_real == d && digits[0] >= '5')
 657         {
 658           /* We rounded to zero but shouldn't have */
 659           nzero--;
 660           nafter = 1;
 661           digits[0] = '1';
 662           ndigits = 1;
 663         }
 664     }
 665   else if (nbefore + nafter < ndigits)
 666     {
 667       ndigits = nbefore + nafter;
 668       i = ndigits;
 669       if (digits[i] >= '5')
 670         {
 671           /* Propagate the carry.  */
 672           for (i--; i >= 0; i--)
 673             {
 674               if (digits[i] != '9')
 675                 {
 676                   digits[i]++;
 677                   break;
 678                 }
 679               digits[i] = '0';
 680             }
 681
 682           if (i < 0)
 683             {
 684               /* The carry overflowed.  Fortunately we have some spare space
 685                  at the start of the buffer.  We may discard some digits, but
 686                  this is ok because we already know they are zero.  */
 687               digits--;
 688               digits[0] = '1';
 689               if (ft == FMT_F)
 690                 {
 691                   if (nzero > 0)
 692                     {
 693                       nzero--;
 694                       nafter++;
 695                     }
 696                   else
 697                     nbefore++;
 698                 }
 699               else if (ft == FMT_EN)
 700                 {
 701                   nbefore++;
 702                   if (nbefore == 4)
 703                     {
 704                       nbefore = 1;
 705                       e += 3;
 706                     }
 707                 }
 708               else
 709                 e++;
 710             }
 711         }
 712     }
 713
 714   /* Calculate the format of the exponent field.  */
 715   if (expchar)
 716     {
 717       edigits = 1;
 718       for (i = abs (e); i >= 10; i /= 10)
 719         edigits++;
 720
 721       if (f->u.real.e < 0)
 722         {
 723           /* Width not specified.  Must be no more than 3 digits.  */
 724           if (e > 999 || e < -999)
 725             edigits = -1;
 726           else
 727             {
 728               edigits = 4;
 729               if (e > 99 || e < -99)
 730                 expchar = ' ';
 731             }
 732         }
 733       else
 734         {
 735           /* Exponent width specified, check it is wide enough.  */
 736           if (edigits > f->u.real.e)
 737             edigits = -1;
 738           else
 739             edigits = f->u.real.e + 2;
 740         }
 741     }
 742   else
 743     edigits = 0;
 744
 745   /* Pick a field size if none was specified.  */
 746   if (w <= 0)
 747     w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
 748
 749   /* Create the ouput buffer.  */
 750   out = write_block (dtp, w);
 751   if (out == NULL)
 752     return;
 753
 754   /* Zero values always output as positive, even if the value was negative
 755      before rounding.  */
 756   for (i = 0; i < ndigits; i++)
 757     {
 758       if (digits[i] != '0')
 759         break;
 760     }
 761   if (i == ndigits)
 762     {
 763       /* The output is zero, so set the sign according to the sign bit unless
 764          -fno-sign-zero was specified.  */
 765       if (compile_options.sign_zero == 1)
 766         sign = calculate_sign (dtp, sign_bit);
 767       else
 768         sign = calculate_sign (dtp, 0);
 769     }
 770
 771   /* Work out how much padding is needed.  */
 772   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
 773   if (sign != SIGN_NONE)
 774     nblanks--;
 775
 776   /* Check the value fits in the specified field width.  */
 777   if (nblanks < 0 || edigits == -1)
 778     {
 779       star_fill (out, w);
 780       return;
 781     }
 782
 783   /* See if we have space for a zero before the decimal point.  */
 784   if (nbefore == 0 && nblanks > 0)
 785     {
 786       leadzero = 1;
 787       nblanks--;
 788     }
 789   else
 790     leadzero = 0;
 791
 792   /* Pad to full field width.  */
 793
 794   if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
 795     {
 796       memset (out, ' ', nblanks);
 797       out += nblanks;
 798     }
 799
 800   /* Output the initial sign (if any).  */
 801   if (sign == SIGN_PLUS)
 802     *(out++) = '+';
 803   else if (sign == SIGN_MINUS)
 804     *(out++) = '-';
 805
 806   /* Output an optional leading zero.  */
 807   if (leadzero)
 808     *(out++) = '0';
 809
 810   /* Output the part before the decimal point, padding with zeros.  */
 811   if (nbefore > 0)
 812     {
 813       if (nbefore > ndigits)
 814         {
 815           i = ndigits;
 816           memcpy (out, digits, i);
 817           ndigits = 0;
 818           while (i < nbefore)
 819             out[i++] = '0';
 820         }
 821       else
 822         {
 823           i = nbefore;
 824           memcpy (out, digits, i);
 825           ndigits -= i;
 826         }
 827
 828       digits += i;
 829       out += nbefore;
 830     }
 831   /* Output the decimal point.  */
 832   *(out++) = '.';
 833
 834   /* Output leading zeros after the decimal point.  */
 835   if (nzero > 0)
 836     {
 837       for (i = 0; i < nzero; i++)
 838         *(out++) = '0';
 839     }
 840
 841   /* Output digits after the decimal point, padding with zeros.  */
 842   if (nafter > 0)
 843     {
 844       if (nafter > ndigits)
 845         i = ndigits;
 846       else
 847         i = nafter;
 848
 849       memcpy (out, digits, i);
 850       while (i < nafter)
 851         out[i++] = '0';
 852
 853       digits += i;
 854       ndigits -= i;
 855       out += nafter;
 856     }
 857
 858   /* Output the exponent.  */
 859   if (expchar)
 860     {
 861       if (expchar != ' ')
 862         {
 863           *(out++) = expchar;
 864           edigits--;
 865         }
 866 #if HAVE_SNPRINTF
 867       snprintf (buffer, sizeof (buffer), "%+0*d", edigits, e);
 868 #else
 869       sprintf (buffer, "%+0*d", edigits, e);
 870 #endif
 871       memcpy (out, buffer, edigits);
 872     }
 873
 874   if (dtp->u.p.no_leading_blank)
 875     {
 876       out += edigits;
 877       memset( out , ' ' , nblanks );
 878       dtp->u.p.no_leading_blank = 0;
 879     }
 880 #undef STR
 881 #undef STR1
 882 #undef MIN_FIELD_WIDTH
 883 }
 884
 885
 886 void
 887 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 888 {
 889   char *p;
 890   GFC_INTEGER_LARGEST n;
 891
 892   p = write_block (dtp, f->u.w);
 893   if (p == NULL)
 894     return;
 895
 896   memset (p, ' ', f->u.w - 1);
 897   n = extract_int (source, len);
 898   p[f->u.w - 1] = (n) ? 'T' : 'F';
 899 }
 900
 901 /* Output a real number according to its format.  */
 902
 903 static void
 904 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 905 {
 906   GFC_REAL_LARGEST n;
 907   int nb =0, res, save_scale_factor;
 908   char * p, fin;
 909   fnode *f2 = NULL;
 910
 911   n = extract_real (source, len);
 912
 913   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 914     {
 915       res = isfinite (n);
 916       if (res == 0)
 917         {
 918           nb =  f->u.real.w;
 919
 920           /* If the field width is zero, the processor must select a width
 921              not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
 922
 923           if (nb == 0) nb = 4;
 924           p = write_block (dtp, nb);
 925           if (p == NULL)
 926             return;
 927           if (nb < 3)
 928             {
 929               memset (p, '*',nb);
 930               return;
 931             }
 932
 933           memset(p, ' ', nb);
 934           res = !isnan (n);
 935           if (res != 0)
 936             {
 937               if (signbit(n))
 938                 {
 939
 940                   /* If the sign is negative and the width is 3, there is
 941                      insufficient room to output '-Inf', so output asterisks */
 942
 943                   if (nb == 3)
 944                     {
 945                       memset (p, '*',nb);
 946                       return;
 947                     }
 948
 949                   /* The negative sign is mandatory */
 950
 951                   fin = '-';
 952                 }
 953               else
 954
 955                   /* The positive sign is optional, but we output it for
 956                      consistency */
 957
 958                   fin = '+';
 959
 960               if (nb > 8)
 961
 962                 /* We have room, so output 'Infinity' */
 963
 964                 memcpy(p + nb - 8, "Infinity", 8);
 965               else
 966
 967                 /* For the case of width equals 8, there is not enough room
 968                    for the sign and 'Infinity' so we go with 'Inf' */
 969
 970                 memcpy(p + nb - 3, "Inf", 3);
 971               if (nb < 9 && nb > 3)
 972                 p[nb - 4] = fin;  /* Put the sign in front of Inf */
 973               else if (nb > 8)
 974                 p[nb - 9] = fin;  /* Put the sign in front of Infinity */
 975             }
 976           else
 977             memcpy(p + nb - 3, "NaN", 3);
 978           return;
 979         }
 980     }
 981
 982   if (f->format != FMT_G)
 983     output_float (dtp, f, n);
 984   else
 985     {
 986       save_scale_factor = dtp->u.p.scale_factor;
 987       f2 = calculate_G_format (dtp, f, n, &nb);
 988       output_float (dtp, f2, n);
 989       dtp->u.p.scale_factor = save_scale_factor;
 990       if (f2 != NULL)
 991         free_mem(f2);
 992
 993       if (nb > 0)
 994         {
 995           p = write_block (dtp, nb);
 996           if (p == NULL)
 997             return;
 998           memset (p, ' ', nb);
 999         }
1000     }
1001 }
1002
1003
1004 static void
1005 write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
1006            const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
1007 {
1008   GFC_UINTEGER_LARGEST n = 0;
1009   int w, m, digits, nzero, nblank;
1010   char *p;
1011   const char *q;
1012   char itoa_buf[GFC_BTOA_BUF_SIZE];
1013
1014   w = f->u.integer.w;
1015   m = f->u.integer.m;
1016
1017   n = extract_uint (source, len);
1018
1019   /* Special case:  */
1020
1021   if (m == 0 && n == 0)
1022     {
1023       if (w == 0)
1024         w = 1;
1025
1026       p = write_block (dtp, w);
1027       if (p == NULL)
1028         return;
1029
1030       memset (p, ' ', w);
1031       goto done;
1032     }
1033
1034   q = conv (n, itoa_buf, sizeof (itoa_buf));
1035   digits = strlen (q);
1036
1037   /* Select a width if none was specified.  The idea here is to always
1038      print something.  */
1039
1040   if (w == 0)
1041     w = ((digits < m) ? m : digits);
1042
1043   p = write_block (dtp, w);
1044   if (p == NULL)
1045     return;
1046
1047   nzero = 0;
1048   if (digits < m)
1049     nzero = m - digits;
1050
1051   /* See if things will work.  */
1052
1053   nblank = w - (nzero + digits);
1054
1055   if (nblank < 0)
1056     {
1057       star_fill (p, w);
1058       goto done;
1059     }
1060
1061
1062   if (!dtp->u.p.no_leading_blank)
1063     {
1064       memset (p, ' ', nblank);
1065       p += nblank;
1066       memset (p, '0', nzero);
1067       p += nzero;
1068       memcpy (p, q, digits);
1069     }
1070   else
1071     {
1072       memset (p, '0', nzero);
1073       p += nzero;
1074       memcpy (p, q, digits);
1075       p += digits;
1076       memset (p, ' ', nblank);
1077       dtp->u.p.no_leading_blank = 0;
1078     }
1079
1080  done:
1081   return;
1082 }
1083
1084 static void
1085 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
1086                int len,
1087                const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
1088 {
1089   GFC_INTEGER_LARGEST n = 0;
1090   int w, m, digits, nsign, nzero, nblank;
1091   char *p;
1092   const char *q;
1093   sign_t sign;
1094   char itoa_buf[GFC_BTOA_BUF_SIZE];
1095
1096   w = f->u.integer.w;
1097   m = f->u.integer.m;
1098
1099   n = extract_int (source, len);
1100
1101   /* Special case:  */
1102
1103   if (m == 0 && n == 0)
1104     {
1105       if (w == 0)
1106         w = 1;
1107
1108       p = write_block (dtp, w);
1109       if (p == NULL)
1110         return;
1111
1112       memset (p, ' ', w);
1113       goto done;
1114     }
1115
1116   sign = calculate_sign (dtp, n < 0);
1117   if (n < 0)
1118     n = -n;
1119
1120   nsign = sign == SIGN_NONE ? 0 : 1;
1121   q = conv (n, itoa_buf, sizeof (itoa_buf));
1122
1123   digits = strlen (q);
1124
1125   /* Select a width if none was specified.  The idea here is to always
1126      print something.  */
1127
1128   if (w == 0)
1129     w = ((digits < m) ? m : digits) + nsign;
1130
1131   p = write_block (dtp, w);
1132   if (p == NULL)
1133     return;
1134
1135   nzero = 0;
1136   if (digits < m)
1137     nzero = m - digits;
1138
1139   /* See if things will work.  */
1140
1141   nblank = w - (nsign + nzero + digits);
1142
1143   if (nblank < 0)
1144     {
1145       star_fill (p, w);
1146       goto done;
1147     }
1148
1149   memset (p, ' ', nblank);
1150   p += nblank;
1151
1152   switch (sign)
1153     {
1154     case SIGN_PLUS:
1155       *p++ = '+';
1156       break;
1157     case SIGN_MINUS:
1158       *p++ = '-';
1159       break;
1160     case SIGN_NONE:
1161       break;
1162     }
1163
1164   memset (p, '0', nzero);
1165   p += nzero;
1166
1167   memcpy (p, q, digits);
1168
1169  done:
1170   return;
1171 }
1172
1173
1174 /* Convert unsigned octal to ascii.  */
1175
1176 static const char *
1177 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1178 {
1179   char *p;
1180
1181   assert (len >= GFC_OTOA_BUF_SIZE);
1182
1183   if (n == 0)
1184     return "0";
1185
1186   p = buffer + GFC_OTOA_BUF_SIZE - 1;
1187   *p = '\0';
1188
1189   while (n != 0)
1190     {
1191       *--p = '0' + (n & 7);
1192       n >>= 3;
1193     }
1194
1195   return p;
1196 }
1197
1198
1199 /* Convert unsigned binary to ascii.  */
1200
1201 static const char *
1202 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1203 {
1204   char *p;
1205
1206   assert (len >= GFC_BTOA_BUF_SIZE);
1207
1208   if (n == 0)
1209     return "0";
1210
1211   p = buffer + GFC_BTOA_BUF_SIZE - 1;
1212   *p = '\0';
1213
1214   while (n != 0)
1215     {
1216       *--p = '0' + (n & 1);
1217       n >>= 1;
1218     }
1219
1220   return p;
1221 }
1222
1223
1224 void
1225 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1226 {
1227   write_decimal (dtp, f, p, len, (void *) gfc_itoa);
1228 }
1229
1230
1231 void
1232 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1233 {
1234   write_int (dtp, f, p, len, btoa);
1235 }
1236
1237
1238 void
1239 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1240 {
1241   write_int (dtp, f, p, len, otoa);
1242 }
1243
1244 void
1245 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1246 {
1247   write_int (dtp, f, p, len, xtoa);
1248 }
1249
1250
1251 void
1252 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1253 {
1254   write_float (dtp, f, p, len);
1255 }
1256
1257
1258 void
1259 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1260 {
1261   write_float (dtp, f, p, len);
1262 }
1263
1264
1265 void
1266 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1267 {
1268   write_float (dtp, f, p, len);
1269 }
1270
1271
1272 void
1273 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1274 {
1275   write_float (dtp, f, p, len);
1276 }
1277
1278
1279 void
1280 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1281 {
1282   write_float (dtp, f, p, len);
1283 }
1284
1285
1286 /* Take care of the X/TR descriptor.  */
1287
1288 void
1289 write_x (st_parameter_dt *dtp, int len, int nspaces)
1290 {
1291   char *p;
1292
1293   p = write_block (dtp, len);
1294   if (p == NULL)
1295     return;
1296
1297   if (nspaces > 0)
1298     memset (&p[len - nspaces], ' ', nspaces);
1299 }
1300
1301
1302 /* List-directed writing.  */
1303
1304
1305 /* Write a single character to the output.  Returns nonzero if
1306    something goes wrong.  */
1307
1308 static int
1309 write_char (st_parameter_dt *dtp, char c)
1310 {
1311   char *p;
1312
1313   p = write_block (dtp, 1);
1314   if (p == NULL)
1315     return 1;
1316
1317   *p = c;
1318
1319   return 0;
1320 }
1321
1322
1323 /* Write a list-directed logical value.  */
1324
1325 static void
1326 write_logical (st_parameter_dt *dtp, const char *source, int length)
1327 {
1328   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1329 }
1330
1331
1332 /* Write a list-directed integer value.  */
1333
1334 static void
1335 write_integer (st_parameter_dt *dtp, const char *source, int length)
1336 {
1337   char *p;
1338   const char *q;
1339   int digits;
1340   int width;
1341   char itoa_buf[GFC_ITOA_BUF_SIZE];
1342
1343   q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
1344
1345   switch (length)
1346     {
1347     case 1:
1348       width = 4;
1349       break;
1350
1351     case 2:
1352       width = 6;
1353       break;
1354
1355     case 4:
1356       width = 11;
1357       break;
1358
1359     case 8:
1360       width = 20;
1361       break;
1362
1363     default:
1364       width = 0;
1365       break;
1366     }
1367
1368   digits = strlen (q);
1369
1370   if (width < digits)
1371     width = digits;
1372   p = write_block (dtp, width);
1373   if (p == NULL)
1374     return;
1375   if (dtp->u.p.no_leading_blank)
1376     {
1377       memcpy (p, q, digits);
1378       memset (p + digits, ' ', width - digits);
1379     }
1380   else
1381     {
1382       memset (p, ' ', width - digits);
1383       memcpy (p + width - digits, q, digits);
1384     }
1385 }
1386
1387
1388 /* Write a list-directed string.  We have to worry about delimiting
1389    the strings if the file has been opened in that mode.  */
1390
1391 static void
1392 write_character (st_parameter_dt *dtp, const char *source, int length)
1393 {
1394   int i, extra;
1395   char *p, d;
1396
1397   switch (dtp->u.p.current_unit->flags.delim)
1398     {
1399     case DELIM_APOSTROPHE:
1400       d = '\'';
1401       break;
1402     case DELIM_QUOTE:
1403       d = '"';
1404       break;
1405     default:
1406       d = ' ';
1407       break;
1408     }
1409
1410   if (d == ' ')
1411     extra = 0;
1412   else
1413     {
1414       extra = 2;
1415
1416       for (i = 0; i < length; i++)
1417         if (source[i] == d)
1418           extra++;
1419     }
1420
1421   p = write_block (dtp, length + extra);
1422   if (p == NULL)
1423     return;
1424
1425   if (d == ' ')
1426     memcpy (p, source, length);
1427   else
1428     {
1429       *p++ = d;
1430
1431       for (i = 0; i < length; i++)
1432         {
1433           *p++ = source[i];
1434           if (source[i] == d)
1435             *p++ = d;
1436         }
1437
1438       *p = d;
1439     }
1440 }
1441
1442
1443 /* Output a real number with default format.
1444    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1445    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
1446
1447 static void
1448 write_real (st_parameter_dt *dtp, const char *source, int length)
1449 {
1450   fnode f ;
1451   int org_scale = dtp->u.p.scale_factor;
1452   f.format = FMT_G;
1453   dtp->u.p.scale_factor = 1;
1454   switch (length)
1455     {
1456     case 4:
1457       f.u.real.w = 14;
1458       f.u.real.d = 7;
1459       f.u.real.e = 2;
1460       break;
1461     case 8:
1462       f.u.real.w = 23;
1463       f.u.real.d = 15;
1464       f.u.real.e = 3;
1465       break;
1466     case 10:
1467       f.u.real.w = 28;
1468       f.u.real.d = 19;
1469       f.u.real.e = 4;
1470       break;
1471     case 16:
1472       f.u.real.w = 43;
1473       f.u.real.d = 34;
1474       f.u.real.e = 4;
1475       break;
1476     default:
1477       internal_error (&dtp->common, "bad real kind");
1478       break;
1479     }
1480   write_float (dtp, &f, source , length);
1481   dtp->u.p.scale_factor = org_scale;
1482 }
1483
1484
1485 static void
1486 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1487 {
1488   if (write_char (dtp, '('))
1489     return;
1490   write_real (dtp, source, kind);
1491
1492   if (write_char (dtp, ','))
1493     return;
1494   write_real (dtp, source + size / 2, kind);
1495
1496   write_char (dtp, ')');
1497 }
1498
1499
1500 /* Write the separator between items.  */
1501
1502 static void
1503 write_separator (st_parameter_dt *dtp)
1504 {
1505   char *p;
1506
1507   p = write_block (dtp, options.separator_len);
1508   if (p == NULL)
1509     return;
1510
1511   memcpy (p, options.separator, options.separator_len);
1512 }
1513
1514
1515 /* Write an item with list formatting.
1516    TODO: handle skipping to the next record correctly, particularly
1517    with strings.  */
1518
1519 static void
1520 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1521                              size_t size)
1522 {
1523   if (dtp->u.p.current_unit == NULL)
1524     return;
1525
1526   if (dtp->u.p.first_item)
1527     {
1528       dtp->u.p.first_item = 0;
1529       write_char (dtp, ' ');
1530     }
1531   else
1532     {
1533       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1534           dtp->u.p.current_unit->flags.delim != DELIM_NONE)
1535         write_separator (dtp);
1536     }
1537
1538   switch (type)
1539     {
1540     case BT_INTEGER:
1541       write_integer (dtp, p, kind);
1542       break;
1543     case BT_LOGICAL:
1544       write_logical (dtp, p, kind);
1545       break;
1546     case BT_CHARACTER:
1547       write_character (dtp, p, kind);
1548       break;
1549     case BT_REAL:
1550       write_real (dtp, p, kind);
1551       break;
1552     case BT_COMPLEX:
1553       write_complex (dtp, p, kind, size);
1554       break;
1555     default:
1556       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1557     }
1558
1559   dtp->u.p.char_flag = (type == BT_CHARACTER);
1560 }
1561
1562
1563 void
1564 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1565                       size_t size, size_t nelems)
1566 {
1567   size_t elem;
1568   char *tmp;
1569
1570   tmp = (char *) p;
1571
1572   /* Big loop over all the elements.  */
1573   for (elem = 0; elem < nelems; elem++)
1574     {
1575       dtp->u.p.item_count++;
1576       list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
1577     }
1578 }
1579
1580 /*                      NAMELIST OUTPUT
1581
1582    nml_write_obj writes a namelist object to the output stream.  It is called
1583    recursively for derived type components:
1584         obj    = is the namelist_info for the current object.
1585         offset = the offset relative to the address held by the object for
1586                  derived type arrays.
1587         base   = is the namelist_info of the derived type, when obj is a
1588                  component.
1589         base_name = the full name for a derived type, including qualifiers
1590                     if any.
1591    The returned value is a pointer to the object beyond the last one
1592    accessed, including nested derived types.  Notice that the namelist is
1593    a linear linked list of objects, including derived types and their
1594    components.  A tree, of sorts, is implied by the compound names of
1595    the derived type components and this is how this function recurses through
1596    the list.  */
1597
1598 /* A generous estimate of the number of characters needed to print
1599    repeat counts and indices, including commas, asterices and brackets.  */
1600
1601 #define NML_DIGITS 20
1602
1603 static namelist_info *
1604 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1605                namelist_info * base, char * base_name)
1606 {
1607   int rep_ctr;
1608   int num;
1609   int nml_carry;
1610   index_type len;
1611   index_type obj_size;
1612   index_type nelem;
1613   index_type dim_i;
1614   index_type clen;
1615   index_type elem_ctr;
1616   index_type obj_name_len;
1617   void * p ;
1618   char cup;
1619   char * obj_name;
1620   char * ext_name;
1621   char rep_buff[NML_DIGITS];
1622   namelist_info * cmp;
1623   namelist_info * retval = obj->next;
1624   size_t base_name_len;
1625   size_t base_var_name_len;
1626   size_t tot_len;
1627
1628   /* Write namelist variable names in upper case. If a derived type,
1629      nothing is output.  If a component, base and base_name are set.  */
1630
1631   if (obj->type != GFC_DTYPE_DERIVED)
1632     {
1633 #ifdef HAVE_CRLF
1634       write_character (dtp, "\r\n ", 3);
1635 #else
1636       write_character (dtp, "\n ", 2);
1637 #endif
1638       len = 0;
1639       if (base)
1640         {
1641           len =strlen (base->var_name);
1642           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1643             {
1644               cup = toupper (base_name[dim_i]);
1645               write_character (dtp, &cup, 1);
1646             }
1647         }
1648       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1649         {
1650           cup = toupper (obj->var_name[dim_i]);
1651           write_character (dtp, &cup, 1);
1652         }
1653       write_character (dtp, "=", 1);
1654     }
1655
1656   /* Counts the number of data output on a line, including names.  */
1657
1658   num = 1;
1659
1660   len = obj->len;
1661
1662   switch (obj->type)
1663     {
1664
1665     case GFC_DTYPE_REAL:
1666       obj_size = size_from_real_kind (len);
1667       break;
1668
1669     case GFC_DTYPE_COMPLEX:
1670       obj_size = size_from_complex_kind (len);
1671       break;
1672
1673     case GFC_DTYPE_CHARACTER:
1674       obj_size = obj->string_length;
1675       break;
1676
1677     default:
1678       obj_size = len;
1679     }
1680
1681   if (obj->var_rank)
1682     obj_size = obj->size;
1683
1684   /* Set the index vector and count the number of elements.  */
1685
1686   nelem = 1;
1687   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1688     {
1689       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1690       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1691     }
1692
1693   /* Main loop to output the data held in the object.  */
1694
1695   rep_ctr = 1;
1696   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1697     {
1698
1699       /* Build the pointer to the data value.  The offset is passed by
1700          recursive calls to this function for arrays of derived types.
1701          Is NULL otherwise.  */
1702
1703       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1704       p += offset;
1705
1706       /* Check for repeat counts of intrinsic types.  */
1707
1708       if ((elem_ctr < (nelem - 1)) &&
1709           (obj->type != GFC_DTYPE_DERIVED) &&
1710           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1711         {
1712           rep_ctr++;
1713         }
1714
1715       /* Execute a repeated output.  Note the flag no_leading_blank that
1716          is used in the functions used to output the intrinsic types.  */
1717
1718       else
1719         {
1720           if (rep_ctr > 1)
1721             {
1722               st_sprintf(rep_buff, " %d*", rep_ctr);
1723               write_character (dtp, rep_buff, strlen (rep_buff));
1724               dtp->u.p.no_leading_blank = 1;
1725             }
1726           num++;
1727
1728           /* Output the data, if an intrinsic type, or recurse into this
1729              routine to treat derived types.  */
1730
1731           switch (obj->type)
1732             {
1733
1734             case GFC_DTYPE_INTEGER:
1735               write_integer (dtp, p, len);
1736               break;
1737
1738             case GFC_DTYPE_LOGICAL:
1739               write_logical (dtp, p, len);
1740               break;
1741
1742             case GFC_DTYPE_CHARACTER:
1743               if (dtp->u.p.nml_delim)
1744                 write_character (dtp, &dtp->u.p.nml_delim, 1);
1745               write_character (dtp, p, obj->string_length);
1746               if (dtp->u.p.nml_delim)
1747                 write_character (dtp, &dtp->u.p.nml_delim, 1);
1748               break;
1749
1750             case GFC_DTYPE_REAL:
1751               write_real (dtp, p, len);
1752               break;
1753
1754             case GFC_DTYPE_COMPLEX:
1755               dtp->u.p.no_leading_blank = 0;
1756               num++;
1757               write_complex (dtp, p, len, obj_size);
1758               break;
1759
1760             case GFC_DTYPE_DERIVED:
1761
1762               /* To treat a derived type, we need to build two strings:
1763                  ext_name = the name, including qualifiers that prepends
1764                             component names in the output - passed to
1765                             nml_write_obj.
1766                  obj_name = the derived type name with no qualifiers but %
1767                             appended.  This is used to identify the
1768                             components.  */
1769
1770               /* First ext_name => get length of all possible components  */
1771
1772               base_name_len = base_name ? strlen (base_name) : 0;
1773               base_var_name_len = base ? strlen (base->var_name) : 0;
1774               ext_name = (char*)get_mem ( base_name_len
1775                                         + base_var_name_len
1776                                         + strlen (obj->var_name)
1777                                         + obj->var_rank * NML_DIGITS
1778                                         + 1);
1779
1780               memcpy (ext_name, base_name, base_name_len);
1781               clen = strlen (obj->var_name + base_var_name_len);
1782               memcpy (ext_name + base_name_len,
1783                       obj->var_name + base_var_name_len, clen);
1784
1785               /* Append the qualifier.  */
1786
1787               tot_len = base_name_len + clen;
1788               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1789                 {
1790                   if (!dim_i)
1791                     {
1792                       ext_name[tot_len] = '(';
1793                       tot_len++;
1794                     }
1795                   st_sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1796                   tot_len += strlen (ext_name + tot_len);
1797                   ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1798                   tot_len++;
1799                 }
1800
1801               ext_name[tot_len] = '\0';
1802
1803               /* Now obj_name.  */
1804
1805               obj_name_len = strlen (obj->var_name) + 1;
1806               obj_name = get_mem (obj_name_len+1);
1807               memcpy (obj_name, obj->var_name, obj_name_len-1);
1808               memcpy (obj_name + obj_name_len-1, "%", 2);
1809
1810               /* Now loop over the components. Update the component pointer
1811                  with the return value from nml_write_obj => this loop jumps
1812                  past nested derived types.  */
1813
1814               for (cmp = obj->next;
1815                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1816                    cmp = retval)
1817                 {
1818                   retval = nml_write_obj (dtp, cmp,
1819                                           (index_type)(p - obj->mem_pos),
1820                                           obj, ext_name);
1821                 }
1822
1823               free_mem (obj_name);
1824               free_mem (ext_name);
1825               goto obj_loop;
1826
1827             default:
1828               internal_error (&dtp->common, "Bad type for namelist write");
1829             }
1830
1831           /* Reset the leading blank suppression, write a comma and, if 5
1832              values have been output, write a newline and advance to column
1833              2. Reset the repeat counter.  */
1834
1835           dtp->u.p.no_leading_blank = 0;
1836           write_character (dtp, ",", 1);
1837           if (num > 5)
1838             {
1839               num = 0;
1840 #ifdef HAVE_CRLF
1841               write_character (dtp, "\r\n ", 3);
1842 #else
1843               write_character (dtp, "\n ", 2);
1844 #endif
1845             }
1846           rep_ctr = 1;
1847         }
1848
1849     /* Cycle through and increment the index vector.  */
1850
1851 obj_loop:
1852
1853     nml_carry = 1;
1854     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1855       {
1856         obj->ls[dim_i].idx += nml_carry ;
1857         nml_carry = 0;
1858         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1859           {
1860             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1861             nml_carry = 1;
1862           }
1863        }
1864     }
1865
1866   /* Return a pointer beyond the furthest object accessed.  */
1867
1868   return retval;
1869 }
1870
1871 /* This is the entry function for namelist writes.  It outputs the name
1872    of the namelist and iterates through the namelist by calls to
1873    nml_write_obj.  The call below has dummys in the arguments used in
1874    the treatment of derived types.  */
1875
1876 void
1877 namelist_write (st_parameter_dt *dtp)
1878 {
1879   namelist_info * t1, *t2, *dummy = NULL;
1880   index_type i;
1881   index_type dummy_offset = 0;
1882   char c;
1883   char * dummy_name = NULL;
1884   unit_delim tmp_delim;
1885
1886   /* Set the delimiter for namelist output.  */
1887
1888   tmp_delim = dtp->u.p.current_unit->flags.delim;
1889   dtp->u.p.current_unit->flags.delim = DELIM_NONE;
1890   switch (tmp_delim)
1891     {
1892     case (DELIM_QUOTE):
1893       dtp->u.p.nml_delim = '"';
1894       break;
1895
1896     case (DELIM_APOSTROPHE):
1897       dtp->u.p.nml_delim = '\'';
1898       break;
1899
1900     default:
1901       dtp->u.p.nml_delim = '\0';
1902       break;
1903     }
1904
1905   write_character (dtp, "&", 1);
1906
1907   /* Write namelist name in upper case - f95 std.  */
1908
1909   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1910     {
1911       c = toupper (dtp->namelist_name[i]);
1912       write_character (dtp, &c ,1);
1913     }
1914
1915   if (dtp->u.p.ionml != NULL)
1916     {
1917       t1 = dtp->u.p.ionml;
1918       while (t1 != NULL)
1919         {
1920           t2 = t1;
1921           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1922         }
1923     }
1924 #ifdef HAVE_CRLF
1925   write_character (dtp, "  /\r\n", 5);
1926 #else
1927   write_character (dtp, "  /\n", 4);
1928 #endif
1929
1930   /* Recover the original delimiter.  */
1931
1932   dtp->u.p.current_unit->flags.delim = tmp_delim;
1933 }
1934
1935 #undef NML_DIGITS