libgfortran/io/write.c

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