libgfortran/io/write.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   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);
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);
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);
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);
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);
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 = 15;
1436       f->u.real.d = 8;
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 = 29;
1446       f->u.real.d = 20;
1447       f->u.real.e = 4;
1448       break;
1449     case 16:
1450       f->u.real.w = 44;
1451       f->u.real.d = 35;
1452       f->u.real.e = 4;
1453       break;
1454     default:
1455       internal_error (&dtp->common, "bad real kind");
1456       break;
1457     }
1458 }
1459 /* Output a real number with default format.
1460    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1461    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
1462 // FX -- FIXME: should we change the default format for __float128-real(16)?
1463
1464 void
1465 write_real (st_parameter_dt *dtp, const char *source, int length)
1466 {
1467   fnode f ;
1468   int org_scale = dtp->u.p.scale_factor;
1469   dtp->u.p.scale_factor = 1;
1470   set_fnode_default (dtp, &f, length);
1471   write_float (dtp, &f, source , length);
1472   dtp->u.p.scale_factor = org_scale;
1473 }
1474
1475
1476 void
1477 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1478 {
1479   fnode f ;
1480   set_fnode_default (dtp, &f, length);
1481   if (d > 0)
1482     f.u.real.d = d;
1483   dtp->u.p.g0_no_blanks = 1;
1484   write_float (dtp, &f, source , length);
1485   dtp->u.p.g0_no_blanks = 0;
1486 }
1487
1488
1489 static void
1490 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1491 {
1492   char semi_comma =
1493         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1494
1495   if (write_char (dtp, '('))
1496     return;
1497   write_real (dtp, source, kind);
1498
1499   if (write_char (dtp, semi_comma))
1500     return;
1501   write_real (dtp, source + size / 2, kind);
1502
1503   write_char (dtp, ')');
1504 }
1505
1506
1507 /* Write the separator between items.  */
1508
1509 static void
1510 write_separator (st_parameter_dt *dtp)
1511 {
1512   char *p;
1513
1514   p = write_block (dtp, options.separator_len);
1515   if (p == NULL)
1516     return;
1517   if (unlikely (is_char4_unit (dtp)))
1518     {
1519       gfc_char4_t *p4 = (gfc_char4_t *) p;
1520       memcpy4 (p4, options.separator, options.separator_len);
1521     }
1522   else
1523     memcpy (p, options.separator, options.separator_len);
1524 }
1525
1526
1527 /* Write an item with list formatting.
1528    TODO: handle skipping to the next record correctly, particularly
1529    with strings.  */
1530
1531 static void
1532 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1533                              size_t size)
1534 {
1535   if (dtp->u.p.current_unit == NULL)
1536     return;
1537
1538   if (dtp->u.p.first_item)
1539     {
1540       dtp->u.p.first_item = 0;
1541       write_char (dtp, ' ');
1542     }
1543   else
1544     {
1545       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1546         dtp->u.p.current_unit->delim_status != DELIM_NONE)
1547       write_separator (dtp);
1548     }
1549
1550   switch (type)
1551     {
1552     case BT_INTEGER:
1553       write_integer (dtp, p, kind);
1554       break;
1555     case BT_LOGICAL:
1556       write_logical (dtp, p, kind);
1557       break;
1558     case BT_CHARACTER:
1559       write_character (dtp, p, kind, size);
1560       break;
1561     case BT_REAL:
1562       write_real (dtp, p, kind);
1563       break;
1564     case BT_COMPLEX:
1565       write_complex (dtp, p, kind, size);
1566       break;
1567     default:
1568       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1569     }
1570
1571   dtp->u.p.char_flag = (type == BT_CHARACTER);
1572 }
1573
1574
1575 void
1576 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1577                       size_t size, size_t nelems)
1578 {
1579   size_t elem;
1580   char *tmp;
1581   size_t stride = type == BT_CHARACTER ?
1582                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1583
1584   tmp = (char *) p;
1585
1586   /* Big loop over all the elements.  */
1587   for (elem = 0; elem < nelems; elem++)
1588     {
1589       dtp->u.p.item_count++;
1590       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1591     }
1592 }
1593
1594 /*                      NAMELIST OUTPUT
1595
1596    nml_write_obj writes a namelist object to the output stream.  It is called
1597    recursively for derived type components:
1598         obj    = is the namelist_info for the current object.
1599         offset = the offset relative to the address held by the object for
1600                  derived type arrays.
1601         base   = is the namelist_info of the derived type, when obj is a
1602                  component.
1603         base_name = the full name for a derived type, including qualifiers
1604                     if any.
1605    The returned value is a pointer to the object beyond the last one
1606    accessed, including nested derived types.  Notice that the namelist is
1607    a linear linked list of objects, including derived types and their
1608    components.  A tree, of sorts, is implied by the compound names of
1609    the derived type components and this is how this function recurses through
1610    the list.  */
1611
1612 /* A generous estimate of the number of characters needed to print
1613    repeat counts and indices, including commas, asterices and brackets.  */
1614
1615 #define NML_DIGITS 20
1616
1617 static void
1618 namelist_write_newline (st_parameter_dt *dtp)
1619 {
1620   if (!is_internal_unit (dtp))
1621     {
1622 #ifdef HAVE_CRLF
1623       write_character (dtp, "\r\n", 1, 2);
1624 #else
1625       write_character (dtp, "\n", 1, 1);
1626 #endif
1627       return;
1628     }
1629
1630   if (is_array_io (dtp))
1631     {
1632       gfc_offset record;
1633       int finished;
1634       char *p;
1635       int length = dtp->u.p.current_unit->bytes_left;
1636
1637       p = write_block (dtp, length);
1638       if (p == NULL)
1639         return;
1640
1641       if (unlikely (is_char4_unit (dtp)))
1642         {
1643           gfc_char4_t *p4 = (gfc_char4_t *) p;
1644           memset4 (p4, ' ', length);
1645         }
1646       else
1647         memset (p, ' ', length);
1648
1649       /* Now that the current record has been padded out,
1650          determine where the next record in the array is. */
1651       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1652                                   &finished);
1653       if (finished)
1654         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1655       else
1656         {
1657           /* Now seek to this record */
1658           record = record * dtp->u.p.current_unit->recl;
1659
1660           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1661             {
1662               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1663               return;
1664             }
1665
1666           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1667         }
1668     }
1669   else
1670     write_character (dtp, " ", 1, 1);
1671 }
1672
1673
1674 static namelist_info *
1675 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1676                namelist_info * base, char * base_name)
1677 {
1678   int rep_ctr;
1679   int num;
1680   int nml_carry;
1681   int len;
1682   index_type obj_size;
1683   index_type nelem;
1684   size_t dim_i;
1685   size_t clen;
1686   index_type elem_ctr;
1687   size_t obj_name_len;
1688   void * p ;
1689   char cup;
1690   char * obj_name;
1691   char * ext_name;
1692   char rep_buff[NML_DIGITS];
1693   namelist_info * cmp;
1694   namelist_info * retval = obj->next;
1695   size_t base_name_len;
1696   size_t base_var_name_len;
1697   size_t tot_len;
1698   unit_delim tmp_delim;
1699
1700   /* Set the character to be used to separate values
1701      to a comma or semi-colon.  */
1702
1703   char semi_comma =
1704         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1705
1706   /* Write namelist variable names in upper case. If a derived type,
1707      nothing is output.  If a component, base and base_name are set.  */
1708
1709   if (obj->type != BT_DERIVED)
1710     {
1711       namelist_write_newline (dtp);
1712       write_character (dtp, " ", 1, 1);
1713
1714       len = 0;
1715       if (base)
1716         {
1717           len = strlen (base->var_name);
1718           base_name_len = strlen (base_name);
1719           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1720             {
1721               cup = toupper ((int) base_name[dim_i]);
1722               write_character (dtp, &cup, 1, 1);
1723             }
1724         }
1725       clen = strlen (obj->var_name);
1726       for (dim_i = len; dim_i < clen; dim_i++)
1727         {
1728           cup = toupper ((int) obj->var_name[dim_i]);
1729           write_character (dtp, &cup, 1, 1);
1730         }
1731       write_character (dtp, "=", 1, 1);
1732     }
1733
1734   /* Counts the number of data output on a line, including names.  */
1735
1736   num = 1;
1737
1738   len = obj->len;
1739
1740   switch (obj->type)
1741     {
1742
1743     case BT_REAL:
1744       obj_size = size_from_real_kind (len);
1745       break;
1746
1747     case BT_COMPLEX:
1748       obj_size = size_from_complex_kind (len);
1749       break;
1750
1751     case BT_CHARACTER:
1752       obj_size = obj->string_length;
1753       break;
1754
1755     default:
1756       obj_size = len;
1757     }
1758
1759   if (obj->var_rank)
1760     obj_size = obj->size;
1761
1762   /* Set the index vector and count the number of elements.  */
1763
1764   nelem = 1;
1765   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1766     {
1767       obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1768       nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1769     }
1770
1771   /* Main loop to output the data held in the object.  */
1772
1773   rep_ctr = 1;
1774   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1775     {
1776
1777       /* Build the pointer to the data value.  The offset is passed by
1778          recursive calls to this function for arrays of derived types.
1779          Is NULL otherwise.  */
1780
1781       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1782       p += offset;
1783
1784       /* Check for repeat counts of intrinsic types.  */
1785
1786       if ((elem_ctr < (nelem - 1)) &&
1787           (obj->type != BT_DERIVED) &&
1788           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1789         {
1790           rep_ctr++;
1791         }
1792
1793       /* Execute a repeated output.  Note the flag no_leading_blank that
1794          is used in the functions used to output the intrinsic types.  */
1795
1796       else
1797         {
1798           if (rep_ctr > 1)
1799             {
1800               sprintf(rep_buff, " %d*", rep_ctr);
1801               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1802               dtp->u.p.no_leading_blank = 1;
1803             }
1804           num++;
1805
1806           /* Output the data, if an intrinsic type, or recurse into this
1807              routine to treat derived types.  */
1808
1809           switch (obj->type)
1810             {
1811
1812             case BT_INTEGER:
1813               write_integer (dtp, p, len);
1814               break;
1815
1816             case BT_LOGICAL:
1817               write_logical (dtp, p, len);
1818               break;
1819
1820             case BT_CHARACTER:
1821               tmp_delim = dtp->u.p.current_unit->delim_status;
1822               if (dtp->u.p.nml_delim == '"')
1823                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1824               if (dtp->u.p.nml_delim == '\'')
1825                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1826               write_character (dtp, p, 1, obj->string_length);
1827                 dtp->u.p.current_unit->delim_status = tmp_delim;
1828               break;
1829
1830             case BT_REAL:
1831               write_real (dtp, p, len);
1832               break;
1833
1834            case BT_COMPLEX:
1835               dtp->u.p.no_leading_blank = 0;
1836               num++;
1837               write_complex (dtp, p, len, obj_size);
1838               break;
1839
1840             case BT_DERIVED:
1841
1842               /* To treat a derived type, we need to build two strings:
1843                  ext_name = the name, including qualifiers that prepends
1844                             component names in the output - passed to
1845                             nml_write_obj.
1846                  obj_name = the derived type name with no qualifiers but %
1847                             appended.  This is used to identify the
1848                             components.  */
1849
1850               /* First ext_name => get length of all possible components  */
1851
1852               base_name_len = base_name ? strlen (base_name) : 0;
1853               base_var_name_len = base ? strlen (base->var_name) : 0;
1854               ext_name = (char*)get_mem ( base_name_len
1855                                         + base_var_name_len
1856                                         + strlen (obj->var_name)
1857                                         + obj->var_rank * NML_DIGITS
1858                                         + 1);
1859
1860               memcpy (ext_name, base_name, base_name_len);
1861               clen = strlen (obj->var_name + base_var_name_len);
1862               memcpy (ext_name + base_name_len,
1863                       obj->var_name + base_var_name_len, clen);
1864
1865               /* Append the qualifier.  */
1866
1867               tot_len = base_name_len + clen;
1868               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1869                 {
1870                   if (!dim_i)
1871                     {
1872                       ext_name[tot_len] = '(';
1873                       tot_len++;
1874                     }
1875                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1876                   tot_len += strlen (ext_name + tot_len);
1877                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1878                   tot_len++;
1879                 }
1880
1881               ext_name[tot_len] = '\0';
1882
1883               /* Now obj_name.  */
1884
1885               obj_name_len = strlen (obj->var_name) + 1;
1886               obj_name = get_mem (obj_name_len+1);
1887               memcpy (obj_name, obj->var_name, obj_name_len-1);
1888               memcpy (obj_name + obj_name_len-1, "%", 2);
1889
1890               /* Now loop over the components. Update the component pointer
1891                  with the return value from nml_write_obj => this loop jumps
1892                  past nested derived types.  */
1893
1894               for (cmp = obj->next;
1895                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1896                    cmp = retval)
1897                 {
1898                   retval = nml_write_obj (dtp, cmp,
1899                                           (index_type)(p - obj->mem_pos),
1900                                           obj, ext_name);
1901                 }
1902
1903               free (obj_name);
1904               free (ext_name);
1905               goto obj_loop;
1906
1907             default:
1908               internal_error (&dtp->common, "Bad type for namelist write");
1909             }
1910
1911           /* Reset the leading blank suppression, write a comma (or semi-colon)
1912              and, if 5 values have been output, write a newline and advance
1913              to column 2. Reset the repeat counter.  */
1914
1915           dtp->u.p.no_leading_blank = 0;
1916           write_character (dtp, &semi_comma, 1, 1);
1917           if (num > 5)
1918             {
1919               num = 0;
1920               namelist_write_newline (dtp);
1921               write_character (dtp, " ", 1, 1);
1922             }
1923           rep_ctr = 1;
1924         }
1925
1926     /* Cycle through and increment the index vector.  */
1927
1928 obj_loop:
1929
1930     nml_carry = 1;
1931     for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1932       {
1933         obj->ls[dim_i].idx += nml_carry ;
1934         nml_carry = 0;
1935         if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
1936           {
1937             obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
1938             nml_carry = 1;
1939           }
1940        }
1941     }
1942
1943   /* Return a pointer beyond the furthest object accessed.  */
1944
1945   return retval;
1946 }
1947
1948
1949 /* This is the entry function for namelist writes.  It outputs the name
1950    of the namelist and iterates through the namelist by calls to
1951    nml_write_obj.  The call below has dummys in the arguments used in
1952    the treatment of derived types.  */
1953
1954 void
1955 namelist_write (st_parameter_dt *dtp)
1956 {
1957   namelist_info * t1, *t2, *dummy = NULL;
1958   index_type i;
1959   index_type dummy_offset = 0;
1960   char c;
1961   char * dummy_name = NULL;
1962   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1963
1964   /* Set the delimiter for namelist output.  */
1965   tmp_delim = dtp->u.p.current_unit->delim_status;
1966
1967   dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
1968
1969   /* Temporarily disable namelist delimters.  */
1970   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1971
1972   write_character (dtp, "&", 1, 1);
1973
1974   /* Write namelist name in upper case - f95 std.  */
1975   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1976     {
1977       c = toupper ((int) dtp->namelist_name[i]);
1978       write_character (dtp, &c, 1 ,1);
1979     }
1980
1981   if (dtp->u.p.ionml != NULL)
1982     {
1983       t1 = dtp->u.p.ionml;
1984       while (t1 != NULL)
1985         {
1986           t2 = t1;
1987           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1988         }
1989     }
1990
1991   namelist_write_newline (dtp);
1992   write_character (dtp, " /", 1, 2);
1993   /* Restore the original delimiter.  */
1994   dtp->u.p.current_unit->delim_status = tmp_delim;
1995 }
1996
1997 #undef NML_DIGITS