libgfortran/io/write.c

   1 /* Copyright (C) 2002-2016 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 /* Take care of the X/TR descriptor.  */
1105
1106 void
1107 write_x (st_parameter_dt *dtp, int len, int nspaces)
1108 {
1109   char *p;
1110
1111   p = write_block (dtp, len);
1112   if (p == NULL)
1113     return;
1114   if (nspaces > 0 && len - nspaces >= 0)
1115     {
1116       if (unlikely (is_char4_unit (dtp)))
1117         {
1118           gfc_char4_t *p4 = (gfc_char4_t *) p;
1119           memset4 (&p4[len - nspaces], ' ', nspaces);
1120         }
1121       else
1122         memset (&p[len - nspaces], ' ', nspaces);
1123     }
1124 }
1125
1126
1127 /* List-directed writing.  */
1128
1129
1130 /* Write a single character to the output.  Returns nonzero if
1131    something goes wrong.  */
1132
1133 static int
1134 write_char (st_parameter_dt *dtp, int c)
1135 {
1136   char *p;
1137
1138   p = write_block (dtp, 1);
1139   if (p == NULL)
1140     return 1;
1141   if (unlikely (is_char4_unit (dtp)))
1142     {
1143       gfc_char4_t *p4 = (gfc_char4_t *) p;
1144       *p4 = c;
1145       return 0;
1146     }
1147
1148   *p = (uchar) c;
1149
1150   return 0;
1151 }
1152
1153
1154 /* Write a list-directed logical value.  */
1155
1156 static void
1157 write_logical (st_parameter_dt *dtp, const char *source, int length)
1158 {
1159   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1160 }
1161
1162
1163 /* Write a list-directed integer value.  */
1164
1165 static void
1166 write_integer (st_parameter_dt *dtp, const char *source, int length)
1167 {
1168   char *p;
1169   const char *q;
1170   int digits;
1171   int width;
1172   char itoa_buf[GFC_ITOA_BUF_SIZE];
1173
1174   q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
1175
1176   switch (length)
1177     {
1178     case 1:
1179       width = 4;
1180       break;
1181
1182     case 2:
1183       width = 6;
1184       break;
1185
1186     case 4:
1187       width = 11;
1188       break;
1189
1190     case 8:
1191       width = 20;
1192       break;
1193
1194     default:
1195       width = 0;
1196       break;
1197     }
1198
1199   digits = strlen (q);
1200
1201   if (width < digits)
1202     width = digits;
1203   p = write_block (dtp, width);
1204   if (p == NULL)
1205     return;
1206
1207   if (unlikely (is_char4_unit (dtp)))
1208     {
1209       gfc_char4_t *p4 = (gfc_char4_t *) p;
1210       if (dtp->u.p.no_leading_blank)
1211         {
1212           memcpy4 (p4, q, digits);
1213           memset4 (p4 + digits, ' ', width - digits);
1214         }
1215       else
1216         {
1217           memset4 (p4, ' ', width - digits);
1218           memcpy4 (p4 + width - digits, q, digits);
1219         }
1220       return;
1221     }
1222
1223   if (dtp->u.p.no_leading_blank)
1224     {
1225       memcpy (p, q, digits);
1226       memset (p + digits, ' ', width - digits);
1227     }
1228   else
1229     {
1230       memset (p, ' ', width - digits);
1231       memcpy (p + width - digits, q, digits);
1232     }
1233 }
1234
1235
1236 /* Write a list-directed string.  We have to worry about delimiting
1237    the strings if the file has been opened in that mode.  */
1238
1239 #define DELIM 1
1240 #define NODELIM 0
1241
1242 static void
1243 write_character (st_parameter_dt *dtp, const char *source, int kind, int length, int mode)
1244 {
1245   int i, extra;
1246   char *p, d;
1247
1248   if (mode == DELIM)
1249     {
1250       switch (dtp->u.p.current_unit->delim_status)
1251         {
1252         case DELIM_APOSTROPHE:
1253           d = '\'';
1254           break;
1255         case DELIM_QUOTE:
1256           d = '"';
1257           break;
1258         default:
1259           d = ' ';
1260           break;
1261         }
1262     }
1263   else
1264     d = ' ';
1265
1266   if (kind == 1)
1267     {
1268       if (d == ' ')
1269         extra = 0;
1270       else
1271         {
1272           extra = 2;
1273
1274           for (i = 0; i < length; i++)
1275             if (source[i] == d)
1276               extra++;
1277         }
1278
1279       p = write_block (dtp, length + extra);
1280       if (p == NULL)
1281         return;
1282
1283       if (unlikely (is_char4_unit (dtp)))
1284         {
1285           gfc_char4_t d4 = (gfc_char4_t) d;
1286           gfc_char4_t *p4 = (gfc_char4_t *) p;
1287
1288           if (d4 == ' ')
1289             memcpy4 (p4, source, length);
1290           else
1291             {
1292               *p4++ = d4;
1293
1294               for (i = 0; i < length; i++)
1295                 {
1296                   *p4++ = (gfc_char4_t) source[i];
1297                   if (source[i] == d)
1298                     *p4++ = d4;
1299                 }
1300
1301               *p4 = d4;
1302             }
1303           return;
1304         }
1305
1306       if (d == ' ')
1307         memcpy (p, source, length);
1308       else
1309         {
1310           *p++ = d;
1311
1312           for (i = 0; i < length; i++)
1313             {
1314               *p++ = source[i];
1315               if (source[i] == d)
1316                 *p++ = d;
1317             }
1318
1319           *p = d;
1320         }
1321     }
1322   else
1323     {
1324       if (d == ' ')
1325         {
1326           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1327             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1328           else
1329             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1330         }
1331       else
1332         {
1333           p = write_block (dtp, 1);
1334           *p = d;
1335
1336           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1337             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1338           else
1339             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1340
1341           p = write_block (dtp, 1);
1342           *p = d;
1343         }
1344     }
1345 }
1346
1347 /* Floating point helper functions.  */
1348
1349 #define BUF_STACK_SZ 256
1350
1351 static int
1352 get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
1353 {
1354   if (f->format != FMT_EN)
1355     return determine_precision (dtp, f, kind);
1356   else
1357     return determine_en_precision (dtp, f, source, kind);
1358 }
1359
1360 static char *
1361 select_buffer (int precision, char *buf, size_t *size)
1362 {
1363   char *result;
1364   *size = BUF_STACK_SZ / 2 + precision;
1365   if (*size > BUF_STACK_SZ)
1366      result = xmalloc (*size);
1367   else
1368      result = buf;
1369   return result;
1370 }
1371
1372 static char *
1373 select_string (const fnode *f, char *buf, size_t *size)
1374 {
1375   char *result;
1376   *size = f->u.real.w + 1;
1377   if (*size > BUF_STACK_SZ)
1378      result = xmalloc (*size);
1379   else
1380      result = buf;
1381   return result;
1382 }
1383
1384 static void
1385 write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
1386 {
1387   char *p = write_block (dtp, len);
1388   if (p == NULL)
1389     return;
1390
1391   if (unlikely (is_char4_unit (dtp)))
1392     {
1393       gfc_char4_t *p4 = (gfc_char4_t *) p;
1394       memcpy4 (p4, fstr, len);
1395       return;
1396     }
1397   memcpy (p, fstr, len);
1398 }
1399
1400 static void
1401 write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
1402 {
1403   char buf_stack[BUF_STACK_SZ];
1404   char str_buf[BUF_STACK_SZ];
1405   char *buffer, *result;
1406   size_t buf_size, res_len;
1407
1408   /* Precision for snprintf call.  */
1409   int precision = get_precision (dtp, f, source, kind);
1410
1411   /* String buffer to hold final result.  */
1412   result = select_string (f, str_buf, &res_len);
1413
1414   buffer = select_buffer (precision, buf_stack, &buf_size);
1415
1416   get_float_string (dtp, f, source , kind, 0, buffer,
1417                            precision, buf_size, result, &res_len);
1418   write_float_string (dtp, result, res_len);
1419
1420   if (buf_size > BUF_STACK_SZ)
1421     free (buffer);
1422   if (res_len > BUF_STACK_SZ)
1423     free (result);
1424 }
1425
1426 void
1427 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1428 {
1429   write_float_0 (dtp, f, p, len);
1430 }
1431
1432
1433 void
1434 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1435 {
1436   write_float_0 (dtp, f, p, len);
1437 }
1438
1439
1440 void
1441 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1442 {
1443   write_float_0 (dtp, f, p, len);
1444 }
1445
1446
1447 void
1448 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1449 {
1450   write_float_0 (dtp, f, p, len);
1451 }
1452
1453
1454 void
1455 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1456 {
1457   write_float_0 (dtp, f, p, len);
1458 }
1459
1460
1461 /* Set an fnode to default format.  */
1462
1463 static void
1464 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1465 {
1466   f->format = FMT_G;
1467   switch (length)
1468     {
1469     case 4:
1470       f->u.real.w = 16;
1471       f->u.real.d = 9;
1472       f->u.real.e = 2;
1473       break;
1474     case 8:
1475       f->u.real.w = 25;
1476       f->u.real.d = 17;
1477       f->u.real.e = 3;
1478       break;
1479     case 10:
1480       f->u.real.w = 30;
1481       f->u.real.d = 21;
1482       f->u.real.e = 4;
1483       break;
1484     case 16:
1485       /* Adjust decimal precision depending on binary precision, 106 or 113.  */
1486 #if GFC_REAL_16_DIGITS == 113
1487       f->u.real.w = 45;
1488       f->u.real.d = 36;
1489       f->u.real.e = 4;
1490 #else
1491       f->u.real.w = 41;
1492       f->u.real.d = 32;
1493       f->u.real.e = 4;
1494 #endif
1495       break;
1496     default:
1497       internal_error (&dtp->common, "bad real kind");
1498       break;
1499     }
1500 }
1501
1502 /* Output a real number with default format.
1503    To guarantee that a binary -> decimal -> binary roundtrip conversion
1504    recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1505    significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1506    Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1507    for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1508    Fortran standard requires outputting an extra digit when the scale
1509    factor is 1 and when the magnitude of the value is such that E
1510    editing is used. However, gfortran compensates for this, and thus
1511    for list formatted the same number of significant digits is
1512    generated both when using F and E editing.  */
1513
1514 void
1515 write_real (st_parameter_dt *dtp, const char *source, int kind)
1516 {
1517   fnode f ;
1518   char buf_stack[BUF_STACK_SZ];
1519   char str_buf[BUF_STACK_SZ];
1520   char *buffer, *result;
1521   size_t buf_size, res_len;
1522   int orig_scale = dtp->u.p.scale_factor;
1523   dtp->u.p.scale_factor = 1;
1524   set_fnode_default (dtp, &f, kind);
1525
1526   /* Precision for snprintf call.  */
1527   int precision = get_precision (dtp, &f, source, kind);
1528
1529   /* String buffer to hold final result.  */
1530   result = select_string (&f, str_buf, &res_len);
1531
1532   /* scratch buffer to hold final result.  */
1533   buffer = select_buffer (precision, buf_stack, &buf_size);
1534
1535   get_float_string (dtp, &f, source , kind, 1, buffer,
1536                            precision, buf_size, result, &res_len);
1537   write_float_string (dtp, result, res_len);
1538
1539   dtp->u.p.scale_factor = orig_scale;
1540   if (buf_size > BUF_STACK_SZ)
1541     free (buffer);
1542   if (res_len > BUF_STACK_SZ)
1543     free (result);
1544 }
1545
1546 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1547    compensate for the extra digit.  */
1548
1549 void
1550 write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
1551 {
1552   fnode f;
1553   char buf_stack[BUF_STACK_SZ];
1554   char str_buf[BUF_STACK_SZ];
1555   char *buffer, *result;
1556   size_t buf_size, res_len;
1557   int comp_d;
1558   set_fnode_default (dtp, &f, kind);
1559
1560   if (d > 0)
1561     f.u.real.d = d;
1562
1563   /* Compensate for extra digits when using scale factor, d is not
1564      specified, and the magnitude is such that E editing is used.  */
1565   if (dtp->u.p.scale_factor > 0 && d == 0)
1566     comp_d = 1;
1567   else
1568     comp_d = 0;
1569   dtp->u.p.g0_no_blanks = 1;
1570
1571   /* Precision for snprintf call.  */
1572   int precision = get_precision (dtp, &f, source, kind);
1573
1574   /* String buffer to hold final result.  */
1575   result = select_string (&f, str_buf, &res_len);
1576
1577   buffer = select_buffer (precision, buf_stack, &buf_size);
1578
1579   get_float_string (dtp, &f, source , kind, comp_d, buffer,
1580                            precision, buf_size, result, &res_len);
1581   write_float_string (dtp, result, res_len);
1582
1583   dtp->u.p.g0_no_blanks = 0;
1584   if (buf_size > BUF_STACK_SZ)
1585     free (buffer);
1586   if (res_len > BUF_STACK_SZ)
1587     free (result);
1588 }
1589
1590
1591 static void
1592 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1593 {
1594   char semi_comma =
1595         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1596
1597   /* Set for no blanks so we get a string result with no leading
1598      blanks.  We will pad left later.  */
1599   dtp->u.p.g0_no_blanks = 1;
1600
1601   fnode f ;
1602   char buf_stack[BUF_STACK_SZ];
1603   char str1_buf[BUF_STACK_SZ];
1604   char str2_buf[BUF_STACK_SZ];
1605   char *buffer, *result1, *result2;
1606   size_t buf_size, res_len1, res_len2;
1607   int width, lblanks, orig_scale = dtp->u.p.scale_factor;
1608
1609   dtp->u.p.scale_factor = 1;
1610   set_fnode_default (dtp, &f, kind);
1611
1612   /* Set width for two values, parenthesis, and comma.  */
1613   width = 2 * f.u.real.w + 3;
1614
1615   /* Set for no blanks so we get a string result with no leading
1616      blanks.  We will pad left later.  */
1617   dtp->u.p.g0_no_blanks = 1;
1618
1619   /* Precision for snprintf call.  */
1620   int precision = get_precision (dtp, &f, source, kind);
1621
1622   /* String buffers to hold final result.  */
1623   result1 = select_string (&f, str1_buf, &res_len1);
1624   result2 = select_string (&f, str2_buf, &res_len2);
1625
1626   buffer = select_buffer (precision, buf_stack, &buf_size);
1627
1628   get_float_string (dtp, &f, source , kind, 0, buffer,
1629                            precision, buf_size, result1, &res_len1);
1630   get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
1631                            precision, buf_size, result2, &res_len2);
1632   lblanks = width - res_len1 - res_len2 - 3;
1633
1634   write_x (dtp, lblanks, lblanks);
1635   write_char (dtp, '(');
1636   write_float_string (dtp, result1, res_len1);
1637   write_char (dtp, semi_comma);
1638   write_float_string (dtp, result2, res_len2);
1639   write_char (dtp, ')');
1640
1641   dtp->u.p.scale_factor = orig_scale;
1642   dtp->u.p.g0_no_blanks = 0;
1643   if (buf_size > BUF_STACK_SZ)
1644     free (buffer);
1645   if (res_len1 > BUF_STACK_SZ)
1646     free (result1);
1647   if (res_len2 > BUF_STACK_SZ)
1648     free (result2);
1649 }
1650
1651
1652 /* Write the separator between items.  */
1653
1654 static void
1655 write_separator (st_parameter_dt *dtp)
1656 {
1657   char *p;
1658
1659   p = write_block (dtp, options.separator_len);
1660   if (p == NULL)
1661     return;
1662   if (unlikely (is_char4_unit (dtp)))
1663     {
1664       gfc_char4_t *p4 = (gfc_char4_t *) p;
1665       memcpy4 (p4, options.separator, options.separator_len);
1666     }
1667   else
1668     memcpy (p, options.separator, options.separator_len);
1669 }
1670
1671
1672 /* Write an item with list formatting.
1673    TODO: handle skipping to the next record correctly, particularly
1674    with strings.  */
1675
1676 static void
1677 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1678                              size_t size)
1679 {
1680   if (dtp->u.p.current_unit == NULL)
1681     return;
1682
1683   if (dtp->u.p.first_item)
1684     {
1685       dtp->u.p.first_item = 0;
1686       write_char (dtp, ' ');
1687     }
1688   else
1689     {
1690       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1691           (dtp->u.p.current_unit->delim_status != DELIM_NONE
1692            && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
1693       write_separator (dtp);
1694     }
1695
1696   switch (type)
1697     {
1698     case BT_INTEGER:
1699       write_integer (dtp, p, kind);
1700       break;
1701     case BT_LOGICAL:
1702       write_logical (dtp, p, kind);
1703       break;
1704     case BT_CHARACTER:
1705       write_character (dtp, p, kind, size, DELIM);
1706       break;
1707     case BT_REAL:
1708       write_real (dtp, p, kind);
1709       break;
1710     case BT_COMPLEX:
1711       write_complex (dtp, p, kind, size);
1712       break;
1713     default:
1714       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1715     }
1716
1717   fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
1718   dtp->u.p.char_flag = (type == BT_CHARACTER);
1719 }
1720
1721
1722 void
1723 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1724                       size_t size, size_t nelems)
1725 {
1726   size_t elem;
1727   char *tmp;
1728   size_t stride = type == BT_CHARACTER ?
1729                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1730
1731   tmp = (char *) p;
1732
1733   /* Big loop over all the elements.  */
1734   for (elem = 0; elem < nelems; elem++)
1735     {
1736       dtp->u.p.item_count++;
1737       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1738     }
1739 }
1740
1741 /*                      NAMELIST OUTPUT
1742
1743    nml_write_obj writes a namelist object to the output stream.  It is called
1744    recursively for derived type components:
1745         obj    = is the namelist_info for the current object.
1746         offset = the offset relative to the address held by the object for
1747                  derived type arrays.
1748         base   = is the namelist_info of the derived type, when obj is a
1749                  component.
1750         base_name = the full name for a derived type, including qualifiers
1751                     if any.
1752    The returned value is a pointer to the object beyond the last one
1753    accessed, including nested derived types.  Notice that the namelist is
1754    a linear linked list of objects, including derived types and their
1755    components.  A tree, of sorts, is implied by the compound names of
1756    the derived type components and this is how this function recurses through
1757    the list.  */
1758
1759 /* A generous estimate of the number of characters needed to print
1760    repeat counts and indices, including commas, asterices and brackets.  */
1761
1762 #define NML_DIGITS 20
1763
1764 static void
1765 namelist_write_newline (st_parameter_dt *dtp)
1766 {
1767   if (!is_internal_unit (dtp))
1768     {
1769 #ifdef HAVE_CRLF
1770       write_character (dtp, "\r\n", 1, 2, NODELIM);
1771 #else
1772       write_character (dtp, "\n", 1, 1, NODELIM);
1773 #endif
1774       return;
1775     }
1776
1777   if (is_array_io (dtp))
1778     {
1779       gfc_offset record;
1780       int finished;
1781       char *p;
1782       int length = dtp->u.p.current_unit->bytes_left;
1783
1784       p = write_block (dtp, length);
1785       if (p == NULL)
1786         return;
1787
1788       if (unlikely (is_char4_unit (dtp)))
1789         {
1790           gfc_char4_t *p4 = (gfc_char4_t *) p;
1791           memset4 (p4, ' ', length);
1792         }
1793       else
1794         memset (p, ' ', length);
1795
1796       /* Now that the current record has been padded out,
1797          determine where the next record in the array is. */
1798       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1799                                   &finished);
1800       if (finished)
1801         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1802       else
1803         {
1804           /* Now seek to this record */
1805           record = record * dtp->u.p.current_unit->recl;
1806
1807           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1808             {
1809               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1810               return;
1811             }
1812
1813           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1814         }
1815     }
1816   else
1817     write_character (dtp, " ", 1, 1, NODELIM);
1818 }
1819
1820
1821 static namelist_info *
1822 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1823                namelist_info * base, char * base_name)
1824 {
1825   int rep_ctr;
1826   int num;
1827   int nml_carry;
1828   int len;
1829   index_type obj_size;
1830   index_type nelem;
1831   size_t dim_i;
1832   size_t clen;
1833   index_type elem_ctr;
1834   size_t obj_name_len;
1835   void * p;
1836   char cup;
1837   char * obj_name;
1838   char * ext_name;
1839   char * q;
1840   size_t ext_name_len;
1841   char rep_buff[NML_DIGITS];
1842   namelist_info * cmp;
1843   namelist_info * retval = obj->next;
1844   size_t base_name_len;
1845   size_t base_var_name_len;
1846   size_t tot_len;
1847
1848   /* Set the character to be used to separate values
1849      to a comma or semi-colon.  */
1850
1851   char semi_comma =
1852         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1853
1854   /* Write namelist variable names in upper case. If a derived type,
1855      nothing is output.  If a component, base and base_name are set.  */
1856
1857   if (obj->type != BT_DERIVED)
1858     {
1859       namelist_write_newline (dtp);
1860       write_character (dtp, " ", 1, 1, NODELIM);
1861
1862       len = 0;
1863       if (base)
1864         {
1865           len = strlen (base->var_name);
1866           base_name_len = strlen (base_name);
1867           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1868             {
1869               cup = toupper ((int) base_name[dim_i]);
1870               write_character (dtp, &cup, 1, 1, NODELIM);
1871             }
1872         }
1873       clen = strlen (obj->var_name);
1874       for (dim_i = len; dim_i < clen; dim_i++)
1875         {
1876           cup = toupper ((int) obj->var_name[dim_i]);
1877           if (cup == '+')
1878             cup = '%';
1879           write_character (dtp, &cup, 1, 1, NODELIM);
1880         }
1881       write_character (dtp, "=", 1, 1, NODELIM);
1882     }
1883
1884   /* Counts the number of data output on a line, including names.  */
1885
1886   num = 1;
1887
1888   len = obj->len;
1889
1890   switch (obj->type)
1891     {
1892
1893     case BT_REAL:
1894       obj_size = size_from_real_kind (len);
1895       break;
1896
1897     case BT_COMPLEX:
1898       obj_size = size_from_complex_kind (len);
1899       break;
1900
1901     case BT_CHARACTER:
1902       obj_size = obj->string_length;
1903       break;
1904
1905     default:
1906       obj_size = len;
1907     }
1908
1909   if (obj->var_rank)
1910     obj_size = obj->size;
1911
1912   /* Set the index vector and count the number of elements.  */
1913
1914   nelem = 1;
1915   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1916     {
1917       obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1918       nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1919     }
1920
1921   /* Main loop to output the data held in the object.  */
1922
1923   rep_ctr = 1;
1924   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1925     {
1926
1927       /* Build the pointer to the data value.  The offset is passed by
1928          recursive calls to this function for arrays of derived types.
1929          Is NULL otherwise.  */
1930
1931       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1932       p += offset;
1933
1934       /* Check for repeat counts of intrinsic types.  */
1935
1936       if ((elem_ctr < (nelem - 1)) &&
1937           (obj->type != BT_DERIVED) &&
1938           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1939         {
1940           rep_ctr++;
1941         }
1942
1943       /* Execute a repeated output.  Note the flag no_leading_blank that
1944          is used in the functions used to output the intrinsic types.  */
1945
1946       else
1947         {
1948           if (rep_ctr > 1)
1949             {
1950               snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
1951               write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
1952               dtp->u.p.no_leading_blank = 1;
1953             }
1954           num++;
1955
1956           /* Output the data, if an intrinsic type, or recurse into this
1957              routine to treat derived types.  */
1958
1959           switch (obj->type)
1960             {
1961
1962             case BT_INTEGER:
1963               write_integer (dtp, p, len);
1964               break;
1965
1966             case BT_LOGICAL:
1967               write_logical (dtp, p, len);
1968               break;
1969
1970             case BT_CHARACTER:
1971               if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1972                 write_character (dtp, p, 4, obj->string_length, DELIM);
1973               else
1974                 write_character (dtp, p, 1, obj->string_length, DELIM);
1975               break;
1976
1977             case BT_REAL:
1978               write_real (dtp, p, len);
1979               break;
1980
1981            case BT_COMPLEX:
1982               dtp->u.p.no_leading_blank = 0;
1983               num++;
1984               write_complex (dtp, p, len, obj_size);
1985               break;
1986
1987             case BT_DERIVED:
1988
1989               /* To treat a derived type, we need to build two strings:
1990                  ext_name = the name, including qualifiers that prepends
1991                             component names in the output - passed to
1992                             nml_write_obj.
1993                  obj_name = the derived type name with no qualifiers but %
1994                             appended.  This is used to identify the
1995                             components.  */
1996
1997               /* First ext_name => get length of all possible components  */
1998
1999               base_name_len = base_name ? strlen (base_name) : 0;
2000               base_var_name_len = base ? strlen (base->var_name) : 0;
2001               ext_name_len = base_name_len + base_var_name_len
2002                 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
2003               ext_name = xmalloc (ext_name_len);
2004
2005               if (base_name)
2006                 memcpy (ext_name, base_name, base_name_len);
2007               clen = strlen (obj->var_name + base_var_name_len);
2008               memcpy (ext_name + base_name_len,
2009                       obj->var_name + base_var_name_len, clen);
2010
2011               /* Append the qualifier.  */
2012
2013               tot_len = base_name_len + clen;
2014               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
2015                 {
2016                   if (!dim_i)
2017                     {
2018                       ext_name[tot_len] = '(';
2019                       tot_len++;
2020                     }
2021                   snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
2022                             (int) obj->ls[dim_i].idx);
2023                   tot_len += strlen (ext_name + tot_len);
2024                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
2025                   tot_len++;
2026                 }
2027
2028               ext_name[tot_len] = '\0';
2029               for (q = ext_name; *q; q++)
2030                 if (*q == '+')
2031                   *q = '%';
2032
2033               /* Now obj_name.  */
2034
2035               obj_name_len = strlen (obj->var_name) + 1;
2036               obj_name = xmalloc (obj_name_len + 1);
2037               memcpy (obj_name, obj->var_name, obj_name_len-1);
2038               memcpy (obj_name + obj_name_len-1, "%", 2);
2039
2040               /* Now loop over the components. Update the component pointer
2041                  with the return value from nml_write_obj => this loop jumps
2042                  past nested derived types.  */
2043
2044               for (cmp = obj->next;
2045                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
2046                    cmp = retval)
2047                 {
2048                   retval = nml_write_obj (dtp, cmp,
2049                                           (index_type)(p - obj->mem_pos),
2050                                           obj, ext_name);
2051                 }
2052
2053               free (obj_name);
2054               free (ext_name);
2055               goto obj_loop;
2056
2057             default:
2058               internal_error (&dtp->common, "Bad type for namelist write");
2059             }
2060
2061           /* Reset the leading blank suppression, write a comma (or semi-colon)
2062              and, if 5 values have been output, write a newline and advance
2063              to column 2. Reset the repeat counter.  */
2064
2065           dtp->u.p.no_leading_blank = 0;
2066           if (obj->type == BT_CHARACTER)
2067             {
2068               if (dtp->u.p.nml_delim != '\0')
2069                 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2070             }
2071           else
2072             write_character (dtp, &semi_comma, 1, 1, NODELIM);
2073           if (num > 5)
2074             {
2075               num = 0;
2076               if (dtp->u.p.nml_delim == '\0')
2077                 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2078               namelist_write_newline (dtp);
2079               write_character (dtp, " ", 1, 1, NODELIM);
2080             }
2081           rep_ctr = 1;
2082         }
2083
2084     /* Cycle through and increment the index vector.  */
2085
2086 obj_loop:
2087
2088       nml_carry = 1;
2089       for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
2090         {
2091           obj->ls[dim_i].idx += nml_carry ;
2092           nml_carry = 0;
2093           if (obj->ls[dim_i].idx  > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
2094             {
2095               obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
2096               nml_carry = 1;
2097             }
2098          }
2099     }
2100
2101   /* Return a pointer beyond the furthest object accessed.  */
2102
2103   return retval;
2104 }
2105
2106
2107 /* This is the entry function for namelist writes.  It outputs the name
2108    of the namelist and iterates through the namelist by calls to
2109    nml_write_obj.  The call below has dummys in the arguments used in
2110    the treatment of derived types.  */
2111
2112 void
2113 namelist_write (st_parameter_dt *dtp)
2114 {
2115   namelist_info * t1, *t2, *dummy = NULL;
2116   index_type i;
2117   index_type dummy_offset = 0;
2118   char c;
2119   char * dummy_name = NULL;
2120
2121   /* Set the delimiter for namelist output.  */
2122   switch (dtp->u.p.current_unit->delim_status)
2123     {
2124       case DELIM_APOSTROPHE:
2125         dtp->u.p.nml_delim = '\'';
2126         break;
2127       case DELIM_QUOTE:
2128       case DELIM_UNSPECIFIED:
2129         dtp->u.p.nml_delim = '"';
2130         break;
2131       default:
2132         dtp->u.p.nml_delim = '\0';
2133     }
2134
2135   write_character (dtp, "&", 1, 1, NODELIM);
2136
2137   /* Write namelist name in upper case - f95 std.  */
2138   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
2139     {
2140       c = toupper ((int) dtp->namelist_name[i]);
2141       write_character (dtp, &c, 1 ,1, NODELIM);
2142     }
2143
2144   if (dtp->u.p.ionml != NULL)
2145     {
2146       t1 = dtp->u.p.ionml;
2147       while (t1 != NULL)
2148         {
2149           t2 = t1;
2150           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
2151         }
2152     }
2153
2154   namelist_write_newline (dtp);
2155   write_character (dtp, " /", 1, 2, NODELIM);
2156 }
2157
2158 #undef NML_DIGITS