libgfortran/io/write.c

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