libgfortran/io/write.c

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