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