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 #define DELIM 1
1316 #define NODELIM 0
1317
1318 static void
1319 write_character (st_parameter_dt *dtp, const char *source, int kind, int length, int mode)
1320 {
1321   int i, extra;
1322   char *p, d;
1323
1324   if (mode == DELIM)
1325     {
1326       switch (dtp->u.p.current_unit->delim_status)
1327         {
1328         case DELIM_APOSTROPHE:
1329           d = '\'';
1330           break;
1331         case DELIM_QUOTE:
1332           d = '"';
1333           break;
1334         default:
1335           d = ' ';
1336           break;
1337         }
1338     }
1339   else
1340     d = ' ';
1341
1342   if (kind == 1)
1343     {
1344       if (d == ' ')
1345         extra = 0;
1346       else
1347         {
1348           extra = 2;
1349
1350           for (i = 0; i < length; i++)
1351             if (source[i] == d)
1352               extra++;
1353         }
1354
1355       p = write_block (dtp, length + extra);
1356       if (p == NULL)
1357         return;
1358
1359       if (unlikely (is_char4_unit (dtp)))
1360         {
1361           gfc_char4_t d4 = (gfc_char4_t) d;
1362           gfc_char4_t *p4 = (gfc_char4_t *) p;
1363
1364           if (d4 == ' ')
1365             memcpy4 (p4, source, length);
1366           else
1367             {
1368               *p4++ = d4;
1369
1370               for (i = 0; i < length; i++)
1371                 {
1372                   *p4++ = (gfc_char4_t) source[i];
1373                   if (source[i] == d)
1374                     *p4++ = d4;
1375                 }
1376
1377               *p4 = d4;
1378             }
1379           return;
1380         }
1381
1382       if (d == ' ')
1383         memcpy (p, source, length);
1384       else
1385         {
1386           *p++ = d;
1387
1388           for (i = 0; i < length; i++)
1389             {
1390               *p++ = source[i];
1391               if (source[i] == d)
1392                 *p++ = d;
1393             }
1394
1395           *p = d;
1396         }
1397     }
1398   else
1399     {
1400       if (d == ' ')
1401         {
1402           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1403             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1404           else
1405             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1406         }
1407       else
1408         {
1409           p = write_block (dtp, 1);
1410           *p = d;
1411
1412           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1413             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1414           else
1415             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1416
1417           p = write_block (dtp, 1);
1418           *p = d;
1419         }
1420     }
1421 }
1422
1423
1424 /* Set an fnode to default format.  */
1425
1426 static void
1427 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1428 {
1429   f->format = FMT_G;
1430   switch (length)
1431     {
1432     case 4:
1433       f->u.real.w = 16;
1434       f->u.real.d = 9;
1435       f->u.real.e = 2;
1436       break;
1437     case 8:
1438       f->u.real.w = 25;
1439       f->u.real.d = 17;
1440       f->u.real.e = 3;
1441       break;
1442     case 10:
1443       f->u.real.w = 30;
1444       f->u.real.d = 21;
1445       f->u.real.e = 4;
1446       break;
1447     case 16:
1448       f->u.real.w = 45;
1449       f->u.real.d = 36;
1450       f->u.real.e = 4;
1451       break;
1452     default:
1453       internal_error (&dtp->common, "bad real kind");
1454       break;
1455     }
1456 }
1457
1458 /* Output a real number with default format.  To guarantee that a
1459    binary -> decimal -> binary roundtrip conversion recovers the
1460    original value, IEEE 754-2008 requires 9, 17, 21 and 36 significant
1461    digits for REAL kinds 4, 8, 10, and 16, respectively. Thus, we use
1462    1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for
1463    REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1464    Fortran standard requires outputting an extra digit when the scale
1465    factor is 1 and when the magnitude of the value is such that E
1466    editing is used. However, gfortran compensates for this, and thus
1467    for list formatted the same number of significant digits is
1468    generated both when using F and E editing.  */
1469
1470 void
1471 write_real (st_parameter_dt *dtp, const char *source, int length)
1472 {
1473   fnode f ;
1474   int org_scale = dtp->u.p.scale_factor;
1475   dtp->u.p.scale_factor = 1;
1476   set_fnode_default (dtp, &f, length);
1477   write_float (dtp, &f, source , length, 1);
1478   dtp->u.p.scale_factor = org_scale;
1479 }
1480
1481 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1482    compensate for the extra digit.  */
1483
1484 void
1485 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1486 {
1487   fnode f;
1488   int comp_d;
1489   set_fnode_default (dtp, &f, length);
1490   if (d > 0)
1491     f.u.real.d = d;
1492
1493   /* Compensate for extra digits when using scale factor, d is not
1494      specified, and the magnitude is such that E editing is used.  */
1495   if (dtp->u.p.scale_factor > 0 && d == 0)
1496     comp_d = 1;
1497   else
1498     comp_d = 0;
1499   dtp->u.p.g0_no_blanks = 1;
1500   write_float (dtp, &f, source , length, comp_d);
1501   dtp->u.p.g0_no_blanks = 0;
1502 }
1503
1504
1505 static void
1506 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1507 {
1508   char semi_comma =
1509         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1510
1511   if (write_char (dtp, '('))
1512     return;
1513   write_real (dtp, source, kind);
1514
1515   if (write_char (dtp, semi_comma))
1516     return;
1517   write_real (dtp, source + size / 2, kind);
1518
1519   write_char (dtp, ')');
1520 }
1521
1522
1523 /* Write the separator between items.  */
1524
1525 static void
1526 write_separator (st_parameter_dt *dtp)
1527 {
1528   char *p;
1529
1530   p = write_block (dtp, options.separator_len);
1531   if (p == NULL)
1532     return;
1533   if (unlikely (is_char4_unit (dtp)))
1534     {
1535       gfc_char4_t *p4 = (gfc_char4_t *) p;
1536       memcpy4 (p4, options.separator, options.separator_len);
1537     }
1538   else
1539     memcpy (p, options.separator, options.separator_len);
1540 }
1541
1542
1543 /* Write an item with list formatting.
1544    TODO: handle skipping to the next record correctly, particularly
1545    with strings.  */
1546
1547 static void
1548 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1549                              size_t size)
1550 {
1551   if (dtp->u.p.current_unit == NULL)
1552     return;
1553
1554   if (dtp->u.p.first_item)
1555     {
1556       dtp->u.p.first_item = 0;
1557       write_char (dtp, ' ');
1558     }
1559   else
1560     {
1561       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1562           (dtp->u.p.current_unit->delim_status != DELIM_NONE
1563            && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
1564       write_separator (dtp);
1565     }
1566
1567   switch (type)
1568     {
1569     case BT_INTEGER:
1570       write_integer (dtp, p, kind);
1571       break;
1572     case BT_LOGICAL:
1573       write_logical (dtp, p, kind);
1574       break;
1575     case BT_CHARACTER:
1576       write_character (dtp, p, kind, size, DELIM);
1577       break;
1578     case BT_REAL:
1579       write_real (dtp, p, kind);
1580       break;
1581     case BT_COMPLEX:
1582       write_complex (dtp, p, kind, size);
1583       break;
1584     default:
1585       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1586     }
1587
1588   dtp->u.p.char_flag = (type == BT_CHARACTER);
1589 }
1590
1591
1592 void
1593 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1594                       size_t size, size_t nelems)
1595 {
1596   size_t elem;
1597   char *tmp;
1598   size_t stride = type == BT_CHARACTER ?
1599                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1600
1601   tmp = (char *) p;
1602
1603   /* Big loop over all the elements.  */
1604   for (elem = 0; elem < nelems; elem++)
1605     {
1606       dtp->u.p.item_count++;
1607       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1608     }
1609 }
1610
1611 /*                      NAMELIST OUTPUT
1612
1613    nml_write_obj writes a namelist object to the output stream.  It is called
1614    recursively for derived type components:
1615         obj    = is the namelist_info for the current object.
1616         offset = the offset relative to the address held by the object for
1617                  derived type arrays.
1618         base   = is the namelist_info of the derived type, when obj is a
1619                  component.
1620         base_name = the full name for a derived type, including qualifiers
1621                     if any.
1622    The returned value is a pointer to the object beyond the last one
1623    accessed, including nested derived types.  Notice that the namelist is
1624    a linear linked list of objects, including derived types and their
1625    components.  A tree, of sorts, is implied by the compound names of
1626    the derived type components and this is how this function recurses through
1627    the list.  */
1628
1629 /* A generous estimate of the number of characters needed to print
1630    repeat counts and indices, including commas, asterices and brackets.  */
1631
1632 #define NML_DIGITS 20
1633
1634 static void
1635 namelist_write_newline (st_parameter_dt *dtp)
1636 {
1637   if (!is_internal_unit (dtp))
1638     {
1639 #ifdef HAVE_CRLF
1640       write_character (dtp, "\r\n", 1, 2, NODELIM);
1641 #else
1642       write_character (dtp, "\n", 1, 1, NODELIM);
1643 #endif
1644       return;
1645     }
1646
1647   if (is_array_io (dtp))
1648     {
1649       gfc_offset record;
1650       int finished;
1651       char *p;
1652       int length = dtp->u.p.current_unit->bytes_left;
1653
1654       p = write_block (dtp, length);
1655       if (p == NULL)
1656         return;
1657
1658       if (unlikely (is_char4_unit (dtp)))
1659         {
1660           gfc_char4_t *p4 = (gfc_char4_t *) p;
1661           memset4 (p4, ' ', length);
1662         }
1663       else
1664         memset (p, ' ', length);
1665
1666       /* Now that the current record has been padded out,
1667          determine where the next record in the array is. */
1668       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1669                                   &finished);
1670       if (finished)
1671         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1672       else
1673         {
1674           /* Now seek to this record */
1675           record = record * dtp->u.p.current_unit->recl;
1676
1677           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1678             {
1679               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1680               return;
1681             }
1682
1683           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1684         }
1685     }
1686   else
1687     write_character (dtp, " ", 1, 1, NODELIM);
1688 }
1689
1690
1691 static namelist_info *
1692 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1693                namelist_info * base, char * base_name)
1694 {
1695   int rep_ctr;
1696   int num;
1697   int nml_carry;
1698   int len;
1699   index_type obj_size;
1700   index_type nelem;
1701   size_t dim_i;
1702   size_t clen;
1703   index_type elem_ctr;
1704   size_t obj_name_len;
1705   void * p ;
1706   char cup;
1707   char * obj_name;
1708   char * ext_name;
1709   size_t ext_name_len;
1710   char rep_buff[NML_DIGITS];
1711   namelist_info * cmp;
1712   namelist_info * retval = obj->next;
1713   size_t base_name_len;
1714   size_t base_var_name_len;
1715   size_t tot_len;
1716
1717   /* Set the character to be used to separate values
1718      to a comma or semi-colon.  */
1719
1720   char semi_comma =
1721         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1722
1723   /* Write namelist variable names in upper case. If a derived type,
1724      nothing is output.  If a component, base and base_name are set.  */
1725
1726   if (obj->type != BT_DERIVED)
1727     {
1728       namelist_write_newline (dtp);
1729       write_character (dtp, " ", 1, 1, NODELIM);
1730
1731       len = 0;
1732       if (base)
1733         {
1734           len = strlen (base->var_name);
1735           base_name_len = strlen (base_name);
1736           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1737             {
1738               cup = toupper ((int) base_name[dim_i]);
1739               write_character (dtp, &cup, 1, 1, NODELIM);
1740             }
1741         }
1742       clen = strlen (obj->var_name);
1743       for (dim_i = len; dim_i < clen; dim_i++)
1744         {
1745           cup = toupper ((int) obj->var_name[dim_i]);
1746           write_character (dtp, &cup, 1, 1, NODELIM);
1747         }
1748       write_character (dtp, "=", 1, 1, NODELIM);
1749     }
1750
1751   /* Counts the number of data output on a line, including names.  */
1752
1753   num = 1;
1754
1755   len = obj->len;
1756
1757   switch (obj->type)
1758     {
1759
1760     case BT_REAL:
1761       obj_size = size_from_real_kind (len);
1762       break;
1763
1764     case BT_COMPLEX:
1765       obj_size = size_from_complex_kind (len);
1766       break;
1767
1768     case BT_CHARACTER:
1769       obj_size = obj->string_length;
1770       break;
1771
1772     default:
1773       obj_size = len;
1774     }
1775
1776   if (obj->var_rank)
1777     obj_size = obj->size;
1778
1779   /* Set the index vector and count the number of elements.  */
1780
1781   nelem = 1;
1782   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1783     {
1784       obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1785       nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1786     }
1787
1788   /* Main loop to output the data held in the object.  */
1789
1790   rep_ctr = 1;
1791   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1792     {
1793
1794       /* Build the pointer to the data value.  The offset is passed by
1795          recursive calls to this function for arrays of derived types.
1796          Is NULL otherwise.  */
1797
1798       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1799       p += offset;
1800
1801       /* Check for repeat counts of intrinsic types.  */
1802
1803       if ((elem_ctr < (nelem - 1)) &&
1804           (obj->type != BT_DERIVED) &&
1805           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1806         {
1807           rep_ctr++;
1808         }
1809
1810       /* Execute a repeated output.  Note the flag no_leading_blank that
1811          is used in the functions used to output the intrinsic types.  */
1812
1813       else
1814         {
1815           if (rep_ctr > 1)
1816             {
1817               snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
1818               write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
1819               dtp->u.p.no_leading_blank = 1;
1820             }
1821           num++;
1822
1823           /* Output the data, if an intrinsic type, or recurse into this
1824              routine to treat derived types.  */
1825
1826           switch (obj->type)
1827             {
1828
1829             case BT_INTEGER:
1830               write_integer (dtp, p, len);
1831               break;
1832
1833             case BT_LOGICAL:
1834               write_logical (dtp, p, len);
1835               break;
1836
1837             case BT_CHARACTER:
1838               write_character (dtp, p, 1, obj->string_length, DELIM);
1839               break;
1840
1841             case BT_REAL:
1842               write_real (dtp, p, len);
1843               break;
1844
1845            case BT_COMPLEX:
1846               dtp->u.p.no_leading_blank = 0;
1847               num++;
1848               write_complex (dtp, p, len, obj_size);
1849               break;
1850
1851             case BT_DERIVED:
1852
1853               /* To treat a derived type, we need to build two strings:
1854                  ext_name = the name, including qualifiers that prepends
1855                             component names in the output - passed to
1856                             nml_write_obj.
1857                  obj_name = the derived type name with no qualifiers but %
1858                             appended.  This is used to identify the
1859                             components.  */
1860
1861               /* First ext_name => get length of all possible components  */
1862
1863               base_name_len = base_name ? strlen (base_name) : 0;
1864               base_var_name_len = base ? strlen (base->var_name) : 0;
1865               ext_name_len = base_name_len + base_var_name_len
1866                 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
1867               ext_name = (char*)xmalloc (ext_name_len);
1868
1869               memcpy (ext_name, base_name, base_name_len);
1870               clen = strlen (obj->var_name + base_var_name_len);
1871               memcpy (ext_name + base_name_len,
1872                       obj->var_name + base_var_name_len, clen);
1873
1874               /* Append the qualifier.  */
1875
1876               tot_len = base_name_len + clen;
1877               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1878                 {
1879                   if (!dim_i)
1880                     {
1881                       ext_name[tot_len] = '(';
1882                       tot_len++;
1883                     }
1884                   snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
1885                             (int) obj->ls[dim_i].idx);
1886                   tot_len += strlen (ext_name + tot_len);
1887                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1888                   tot_len++;
1889                 }
1890
1891               ext_name[tot_len] = '\0';
1892
1893               /* Now obj_name.  */
1894
1895               obj_name_len = strlen (obj->var_name) + 1;
1896               obj_name = xmalloc (obj_name_len+1);
1897               memcpy (obj_name, obj->var_name, obj_name_len-1);
1898               memcpy (obj_name + obj_name_len-1, "%", 2);
1899
1900               /* Now loop over the components. Update the component pointer
1901                  with the return value from nml_write_obj => this loop jumps
1902                  past nested derived types.  */
1903
1904               for (cmp = obj->next;
1905                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1906                    cmp = retval)
1907                 {
1908                   retval = nml_write_obj (dtp, cmp,
1909                                           (index_type)(p - obj->mem_pos),
1910                                           obj, ext_name);
1911                 }
1912
1913               free (obj_name);
1914               free (ext_name);
1915               goto obj_loop;
1916
1917             default:
1918               internal_error (&dtp->common, "Bad type for namelist write");
1919             }
1920
1921           /* Reset the leading blank suppression, write a comma (or semi-colon)
1922              and, if 5 values have been output, write a newline and advance
1923              to column 2. Reset the repeat counter.  */
1924
1925           dtp->u.p.no_leading_blank = 0;
1926           if (obj->type == BT_CHARACTER)
1927             {
1928               if (dtp->u.p.nml_delim != '\0')
1929                 write_character (dtp, &semi_comma, 1, 1, NODELIM);
1930             }
1931           else
1932             write_character (dtp, &semi_comma, 1, 1, NODELIM);
1933           if (num > 5)
1934             {
1935               num = 0;
1936               if (dtp->u.p.nml_delim == '\0')
1937                 write_character (dtp, &semi_comma, 1, 1, NODELIM);
1938               namelist_write_newline (dtp);
1939               write_character (dtp, " ", 1, 1, NODELIM);
1940             }
1941           rep_ctr = 1;
1942         }
1943
1944     /* Cycle through and increment the index vector.  */
1945
1946 obj_loop:
1947
1948       nml_carry = 1;
1949       for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1950         {
1951           obj->ls[dim_i].idx += nml_carry ;
1952           nml_carry = 0;
1953           if (obj->ls[dim_i].idx  > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
1954             {
1955               obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
1956               nml_carry = 1;
1957             }
1958          }
1959     }
1960
1961   /* Return a pointer beyond the furthest object accessed.  */
1962
1963   return retval;
1964 }
1965
1966
1967 /* This is the entry function for namelist writes.  It outputs the name
1968    of the namelist and iterates through the namelist by calls to
1969    nml_write_obj.  The call below has dummys in the arguments used in
1970    the treatment of derived types.  */
1971
1972 void
1973 namelist_write (st_parameter_dt *dtp)
1974 {
1975   namelist_info * t1, *t2, *dummy = NULL;
1976   index_type i;
1977   index_type dummy_offset = 0;
1978   char c;
1979   char * dummy_name = NULL;
1980
1981   /* Set the delimiter for namelist output.  */
1982   switch (dtp->u.p.current_unit->delim_status)
1983     {
1984       case DELIM_APOSTROPHE:
1985         dtp->u.p.nml_delim = '\'';
1986         break;
1987       case DELIM_QUOTE:
1988       case DELIM_UNSPECIFIED:
1989         dtp->u.p.nml_delim = '"';
1990         break;
1991       default:
1992         dtp->u.p.nml_delim = '\0';
1993     }
1994
1995   write_character (dtp, "&", 1, 1, NODELIM);
1996
1997   /* Write namelist name in upper case - f95 std.  */
1998   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1999     {
2000       c = toupper ((int) dtp->namelist_name[i]);
2001       write_character (dtp, &c, 1 ,1, NODELIM);
2002     }
2003
2004   if (dtp->u.p.ionml != NULL)
2005     {
2006       t1 = dtp->u.p.ionml;
2007       while (t1 != NULL)
2008         {
2009           t2 = t1;
2010           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
2011         }
2012     }
2013
2014   namelist_write_newline (dtp);
2015   write_character (dtp, " /", 1, 2, NODELIM);
2016 }
2017
2018 #undef NML_DIGITS