libgfortran/io/write.c

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