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