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