libgfortran/io/write.c

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