libgfortran/io/write.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   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 95 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 <assert.h>
  30 #include <string.h>
  31 #include <ctype.h>
  32 #include <stdlib.h>
  33 #include <stdbool.h>
  34 #include <errno.h>
  35 #define star_fill(p, n) memset(p, '*', n)
  36
  37 #include "write_float.def"
  38
  39 typedef unsigned char uchar;
  40
  41 /* Write out default char4.  */
  42
  43 static void
  44 write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
  45                      int src_len, int w_len)
  46 {
  47   char *p;
  48   int j, k = 0;
  49   gfc_char4_t c;
  50   uchar d;
  51
  52   /* Take care of preceding blanks.  */
  53   if (w_len > src_len)
  54     {
  55       k = w_len - src_len;
  56       p = write_block (dtp, k);
  57       if (p == NULL)
  58         return;
  59       memset (p, ' ', k);
  60     }
  61
  62   /* Get ready to handle delimiters if needed.  */
  63   switch (dtp->u.p.current_unit->delim_status)
  64     {
  65     case DELIM_APOSTROPHE:
  66       d = '\'';
  67       break;
  68     case DELIM_QUOTE:
  69       d = '"';
  70       break;
  71     default:
  72       d = ' ';
  73       break;
  74     }
  75
  76   /* Now process the remaining characters, one at a time.  */
  77   for (j = k; j < src_len; j++)
  78     {
  79       c = source[j];
  80
  81       /* Handle delimiters if any.  */
  82       if (c == d && d != ' ')
  83         {
  84           p = write_block (dtp, 2);
  85           if (p == NULL)
  86             return;
  87           *p++ = (uchar) c;
  88         }
  89       else
  90         {
  91           p = write_block (dtp, 1);
  92           if (p == NULL)
  93             return;
  94         }
  95       *p = c > 255 ? '?' : (uchar) c;
  96     }
  97 }
  98
  99
 100 /* Write out UTF-8 converted from char4.  */
 101
 102 static void
 103 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
 104                      int src_len, int w_len)
 105 {
 106   char *p;
 107   int j, k = 0;
 108   gfc_char4_t c;
 109   static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
 110   static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
 111   int nbytes;
 112   uchar buf[6], d, *q;
 113
 114   /* Take care of preceding blanks.  */
 115   if (w_len > src_len)
 116     {
 117       k = w_len - src_len;
 118       p = write_block (dtp, k);
 119       if (p == NULL)
 120         return;
 121       memset (p, ' ', k);
 122     }
 123
 124   /* Get ready to handle delimiters if needed.  */
 125   switch (dtp->u.p.current_unit->delim_status)
 126     {
 127     case DELIM_APOSTROPHE:
 128       d = '\'';
 129       break;
 130     case DELIM_QUOTE:
 131       d = '"';
 132       break;
 133     default:
 134       d = ' ';
 135       break;
 136     }
 137
 138   /* Now process the remaining characters, one at a time.  */
 139   for (j = k; j < src_len; j++)
 140     {
 141       c = source[j];
 142       if (c < 0x80)
 143         {
 144           /* Handle the delimiters if any.  */
 145           if (c == d && d != ' ')
 146             {
 147               p = write_block (dtp, 2);
 148               if (p == NULL)
 149                 return;
 150               *p++ = (uchar) c;
 151             }
 152           else
 153             {
 154               p = write_block (dtp, 1);
 155               if (p == NULL)
 156                 return;
 157             }
 158           *p = (uchar) c;
 159         }
 160       else
 161         {
 162           /* Convert to UTF-8 sequence.  */
 163           nbytes = 1;
 164           q = &buf[6];
 165
 166           do
 167             {
 168               *--q = ((c & 0x3F) | 0x80);
 169               c >>= 6;
 170               nbytes++;
 171             }
 172           while (c >= 0x3F || (c & limits[nbytes-1]));
 173
 174           *--q = (c | masks[nbytes-1]);
 175
 176           p = write_block (dtp, nbytes);
 177           if (p == NULL)
 178             return;
 179
 180           while (q < &buf[6])
 181             *p++ = *q++;
 182         }
 183     }
 184 }
 185
 186
 187 void
 188 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 189 {
 190   int wlen;
 191   char *p;
 192
 193   wlen = f->u.string.length < 0
 194          || (f->format == FMT_G && f->u.string.length == 0)
 195          ? len : f->u.string.length;
 196
 197 #ifdef HAVE_CRLF
 198   /* If this is formatted STREAM IO convert any embedded line feed characters
 199      to CR_LF on systems that use that sequence for newlines.  See F2003
 200      Standard sections 10.6.3 and 9.9 for further information.  */
 201   if (is_stream_io (dtp))
 202     {
 203       const char crlf[] = "\r\n";
 204       int i, q, bytes;
 205       q = bytes = 0;
 206
 207       /* Write out any padding if needed.  */
 208       if (len < wlen)
 209         {
 210           p = write_block (dtp, wlen - len);
 211           if (p == NULL)
 212             return;
 213           memset (p, ' ', wlen - len);
 214         }
 215
 216       /* Scan the source string looking for '\n' and convert it if found.  */
 217       for (i = 0; i < wlen; i++)
 218         {
 219           if (source[i] == '\n')
 220             {
 221               /* Write out the previously scanned characters in the string.  */
 222               if (bytes > 0)
 223                 {
 224                   p = write_block (dtp, bytes);
 225                   if (p == NULL)
 226                     return;
 227                   memcpy (p, &source[q], bytes);
 228                   q += bytes;
 229                   bytes = 0;
 230                 }
 231
 232               /* Write out the CR_LF sequence.  */
 233               q++;
 234               p = write_block (dtp, 2);
 235               if (p == NULL)
 236                 return;
 237               memcpy (p, crlf, 2);
 238             }
 239           else
 240             bytes++;
 241         }
 242
 243       /*  Write out any remaining bytes if no LF was found.  */
 244       if (bytes > 0)
 245         {
 246           p = write_block (dtp, bytes);
 247           if (p == NULL)
 248             return;
 249           memcpy (p, &source[q], bytes);
 250         }
 251     }
 252   else
 253     {
 254 #endif
 255       p = write_block (dtp, wlen);
 256       if (p == NULL)
 257         return;
 258
 259       if (wlen < len)
 260         memcpy (p, source, wlen);
 261       else
 262         {
 263           memset (p, ' ', wlen - len);
 264           memcpy (p + wlen - len, source, len);
 265         }
 266 #ifdef HAVE_CRLF
 267     }
 268 #endif
 269 }
 270
 271
 272 /* The primary difference between write_a_char4 and write_a is that we have to
 273    deal with writing from the first byte of the 4-byte character and pay
 274    attention to the most significant bytes.  For ENCODING="default" write the
 275    lowest significant byte. If the 3 most significant bytes contain
 276    non-zero values, emit a '?'.  For ENCODING="utf-8", convert the UCS-32 value
 277    to the UTF-8 encoded string before writing out.  */
 278
 279 void
 280 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 281 {
 282   int wlen;
 283   gfc_char4_t *q;
 284
 285   wlen = f->u.string.length < 0
 286          || (f->format == FMT_G && f->u.string.length == 0)
 287          ? len : f->u.string.length;
 288
 289   q = (gfc_char4_t *) source;
 290 #ifdef HAVE_CRLF
 291   /* If this is formatted STREAM IO convert any embedded line feed characters
 292      to CR_LF on systems that use that sequence for newlines.  See F2003
 293      Standard sections 10.6.3 and 9.9 for further information.  */
 294   if (is_stream_io (dtp))
 295     {
 296       const char crlf[] = "\r\n";
 297       int i, bytes;
 298       gfc_char4_t *qq;
 299       bytes = 0;
 300
 301       /* Write out any padding if needed.  */
 302       if (len < wlen)
 303         {
 304           char *p;
 305           p = write_block (dtp, wlen - len);
 306           if (p == NULL)
 307             return;
 308           memset (p, ' ', wlen - len);
 309         }
 310
 311       /* Scan the source string looking for '\n' and convert it if found.  */
 312       qq = (gfc_char4_t *) source;
 313       for (i = 0; i < wlen; i++)
 314         {
 315           if (qq[i] == '\n')
 316             {
 317               /* Write out the previously scanned characters in the string.  */
 318               if (bytes > 0)
 319                 {
 320                   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 321                     write_utf8_char4 (dtp, q, bytes, 0);
 322                   else
 323                     write_default_char4 (dtp, q, bytes, 0);
 324                   bytes = 0;
 325                 }
 326
 327               /* Write out the CR_LF sequence.  */
 328               write_default_char4 (dtp, crlf, 2, 0);
 329             }
 330           else
 331             bytes++;
 332         }
 333
 334       /*  Write out any remaining bytes if no LF was found.  */
 335       if (bytes > 0)
 336         {
 337           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 338             write_utf8_char4 (dtp, q, bytes, 0);
 339           else
 340             write_default_char4 (dtp, q, bytes, 0);
 341         }
 342     }
 343   else
 344     {
 345 #endif
 346       if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 347         write_utf8_char4 (dtp, q, len, wlen);
 348       else
 349         write_default_char4 (dtp, q, len, wlen);
 350 #ifdef HAVE_CRLF
 351     }
 352 #endif
 353 }
 354
 355
 356 static GFC_INTEGER_LARGEST
 357 extract_int (const void *p, int len)
 358 {
 359   GFC_INTEGER_LARGEST i = 0;
 360
 361   if (p == NULL)
 362     return i;
 363
 364   switch (len)
 365     {
 366     case 1:
 367       {
 368         GFC_INTEGER_1 tmp;
 369         memcpy ((void *) &tmp, p, len);
 370         i = tmp;
 371       }
 372       break;
 373     case 2:
 374       {
 375         GFC_INTEGER_2 tmp;
 376         memcpy ((void *) &tmp, p, len);
 377         i = tmp;
 378       }
 379       break;
 380     case 4:
 381       {
 382         GFC_INTEGER_4 tmp;
 383         memcpy ((void *) &tmp, p, len);
 384         i = tmp;
 385       }
 386       break;
 387     case 8:
 388       {
 389         GFC_INTEGER_8 tmp;
 390         memcpy ((void *) &tmp, p, len);
 391         i = tmp;
 392       }
 393       break;
 394 #ifdef HAVE_GFC_INTEGER_16
 395     case 16:
 396       {
 397         GFC_INTEGER_16 tmp;
 398         memcpy ((void *) &tmp, p, len);
 399         i = tmp;
 400       }
 401       break;
 402 #endif
 403     default:
 404       internal_error (NULL, "bad integer kind");
 405     }
 406
 407   return i;
 408 }
 409
 410 static GFC_UINTEGER_LARGEST
 411 extract_uint (const void *p, int len)
 412 {
 413   GFC_UINTEGER_LARGEST i = 0;
 414
 415   if (p == NULL)
 416     return i;
 417
 418   switch (len)
 419     {
 420     case 1:
 421       {
 422         GFC_INTEGER_1 tmp;
 423         memcpy ((void *) &tmp, p, len);
 424         i = (GFC_UINTEGER_1) tmp;
 425       }
 426       break;
 427     case 2:
 428       {
 429         GFC_INTEGER_2 tmp;
 430         memcpy ((void *) &tmp, p, len);
 431         i = (GFC_UINTEGER_2) tmp;
 432       }
 433       break;
 434     case 4:
 435       {
 436         GFC_INTEGER_4 tmp;
 437         memcpy ((void *) &tmp, p, len);
 438         i = (GFC_UINTEGER_4) tmp;
 439       }
 440       break;
 441     case 8:
 442       {
 443         GFC_INTEGER_8 tmp;
 444         memcpy ((void *) &tmp, p, len);
 445         i = (GFC_UINTEGER_8) tmp;
 446       }
 447       break;
 448 #ifdef HAVE_GFC_INTEGER_16
 449     case 16:
 450       {
 451         GFC_INTEGER_16 tmp;
 452         memcpy ((void *) &tmp, p, len);
 453         i = (GFC_UINTEGER_16) tmp;
 454       }
 455       break;
 456 #endif
 457     default:
 458       internal_error (NULL, "bad integer kind");
 459     }
 460
 461   return i;
 462 }
 463
 464
 465 void
 466 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 467 {
 468   char *p;
 469   int wlen;
 470   GFC_INTEGER_LARGEST n;
 471
 472   wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
 473
 474   p = write_block (dtp, wlen);
 475   if (p == NULL)
 476     return;
 477
 478   memset (p, ' ', wlen - 1);
 479   n = extract_int (source, len);
 480   p[wlen - 1] = (n) ? 'T' : 'F';
 481 }
 482
 483
 484 static void
 485 write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
 486            const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
 487 {
 488   GFC_UINTEGER_LARGEST n = 0;
 489   int w, m, digits, nzero, nblank;
 490   char *p;
 491   const char *q;
 492   char itoa_buf[GFC_BTOA_BUF_SIZE];
 493
 494   w = f->u.integer.w;
 495   m = f->u.integer.m;
 496
 497   n = extract_uint (source, len);
 498
 499   /* Special case:  */
 500
 501   if (m == 0 && n == 0)
 502     {
 503       if (w == 0)
 504         w = 1;
 505
 506       p = write_block (dtp, w);
 507       if (p == NULL)
 508         return;
 509
 510       memset (p, ' ', w);
 511       goto done;
 512     }
 513
 514   q = conv (n, itoa_buf, sizeof (itoa_buf));
 515   digits = strlen (q);
 516
 517   /* Select a width if none was specified.  The idea here is to always
 518      print something.  */
 519
 520   if (w == 0)
 521     w = ((digits < m) ? m : digits);
 522
 523   p = write_block (dtp, w);
 524   if (p == NULL)
 525     return;
 526
 527   nzero = 0;
 528   if (digits < m)
 529     nzero = m - digits;
 530
 531   /* See if things will work.  */
 532
 533   nblank = w - (nzero + digits);
 534
 535   if (nblank < 0)
 536     {
 537       star_fill (p, w);
 538       goto done;
 539     }
 540
 541
 542   if (!dtp->u.p.no_leading_blank)
 543     {
 544       memset (p, ' ', nblank);
 545       p += nblank;
 546       memset (p, '0', nzero);
 547       p += nzero;
 548       memcpy (p, q, digits);
 549     }
 550   else
 551     {
 552       memset (p, '0', nzero);
 553       p += nzero;
 554       memcpy (p, q, digits);
 555       p += digits;
 556       memset (p, ' ', nblank);
 557       dtp->u.p.no_leading_blank = 0;
 558     }
 559
 560  done:
 561   return;
 562 }
 563
 564 static void
 565 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
 566                int len,
 567                const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
 568 {
 569   GFC_INTEGER_LARGEST n = 0;
 570   int w, m, digits, nsign, nzero, nblank;
 571   char *p;
 572   const char *q;
 573   sign_t sign;
 574   char itoa_buf[GFC_BTOA_BUF_SIZE];
 575
 576   w = f->u.integer.w;
 577   m = f->format == FMT_G ? -1 : f->u.integer.m;
 578
 579   n = extract_int (source, len);
 580
 581   /* Special case:  */
 582   if (m == 0 && n == 0)
 583     {
 584       if (w == 0)
 585         w = 1;
 586
 587       p = write_block (dtp, w);
 588       if (p == NULL)
 589         return;
 590
 591       memset (p, ' ', w);
 592       goto done;
 593     }
 594
 595   sign = calculate_sign (dtp, n < 0);
 596   if (n < 0)
 597     n = -n;
 598   nsign = sign == S_NONE ? 0 : 1;
 599
 600   /* conv calls itoa which sets the negative sign needed
 601      by write_integer. The sign '+' or '-' is set below based on sign
 602      calculated above, so we just point past the sign in the string
 603      before proceeding to avoid double signs in corner cases.
 604      (see PR38504)  */
 605   q = conv (n, itoa_buf, sizeof (itoa_buf));
 606   if (*q == '-')
 607     q++;
 608
 609   digits = strlen (q);
 610
 611   /* Select a width if none was specified.  The idea here is to always
 612      print something.  */
 613
 614   if (w == 0)
 615     w = ((digits < m) ? m : digits) + nsign;
 616
 617   p = write_block (dtp, w);
 618   if (p == NULL)
 619     return;
 620
 621   nzero = 0;
 622   if (digits < m)
 623     nzero = m - digits;
 624
 625   /* See if things will work.  */
 626
 627   nblank = w - (nsign + nzero + digits);
 628
 629   if (nblank < 0)
 630     {
 631       star_fill (p, w);
 632       goto done;
 633     }
 634
 635   memset (p, ' ', nblank);
 636   p += nblank;
 637
 638   switch (sign)
 639     {
 640     case S_PLUS:
 641       *p++ = '+';
 642       break;
 643     case S_MINUS:
 644       *p++ = '-';
 645       break;
 646     case S_NONE:
 647       break;
 648     }
 649
 650   memset (p, '0', nzero);
 651   p += nzero;
 652
 653   memcpy (p, q, digits);
 654
 655  done:
 656   return;
 657 }
 658
 659
 660 /* Convert unsigned octal to ascii.  */
 661
 662 static const char *
 663 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 664 {
 665   char *p;
 666
 667   assert (len >= GFC_OTOA_BUF_SIZE);
 668
 669   if (n == 0)
 670     return "0";
 671
 672   p = buffer + GFC_OTOA_BUF_SIZE - 1;
 673   *p = '\0';
 674
 675   while (n != 0)
 676     {
 677       *--p = '0' + (n & 7);
 678       n >>= 3;
 679     }
 680
 681   return p;
 682 }
 683
 684
 685 /* Convert unsigned binary to ascii.  */
 686
 687 static const char *
 688 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 689 {
 690   char *p;
 691
 692   assert (len >= GFC_BTOA_BUF_SIZE);
 693
 694   if (n == 0)
 695     return "0";
 696
 697   p = buffer + GFC_BTOA_BUF_SIZE - 1;
 698   *p = '\0';
 699
 700   while (n != 0)
 701     {
 702       *--p = '0' + (n & 1);
 703       n >>= 1;
 704     }
 705
 706   return p;
 707 }
 708
 709
 710 /* gfc_itoa()-- Integer to decimal conversion.
 711    The itoa function is a widespread non-standard extension to standard
 712    C, often declared in <stdlib.h>.  Even though the itoa defined here
 713    is a static function we take care not to conflict with any prior
 714    non-static declaration.  Hence the 'gfc_' prefix, which is normally
 715    reserved for functions with external linkage.  */
 716
 717 static const char *
 718 gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
 719 {
 720   int negative;
 721   char *p;
 722   GFC_UINTEGER_LARGEST t;
 723
 724   assert (len >= GFC_ITOA_BUF_SIZE);
 725
 726   if (n == 0)
 727     return "0";
 728
 729   negative = 0;
 730   t = n;
 731   if (n < 0)
 732     {
 733       negative = 1;
 734       t = -n; /*must use unsigned to protect from overflow*/
 735     }
 736
 737   p = buffer + GFC_ITOA_BUF_SIZE - 1;
 738   *p = '\0';
 739
 740   while (t != 0)
 741     {
 742       *--p = '0' + (t % 10);
 743       t /= 10;
 744     }
 745
 746   if (negative)
 747     *--p = '-';
 748   return p;
 749 }
 750
 751
 752 void
 753 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 754 {
 755   write_decimal (dtp, f, p, len, (void *) gfc_itoa);
 756 }
 757
 758
 759 void
 760 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 761 {
 762   write_int (dtp, f, p, len, btoa);
 763 }
 764
 765
 766 void
 767 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 768 {
 769   write_int (dtp, f, p, len, otoa);
 770 }
 771
 772 void
 773 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 774 {
 775   write_int (dtp, f, p, len, gfc_xtoa);
 776 }
 777
 778
 779 void
 780 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 781 {
 782   write_float (dtp, f, p, len);
 783 }
 784
 785
 786 void
 787 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 788 {
 789   write_float (dtp, f, p, len);
 790 }
 791
 792
 793 void
 794 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 795 {
 796   write_float (dtp, f, p, len);
 797 }
 798
 799
 800 void
 801 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 802 {
 803   write_float (dtp, f, p, len);
 804 }
 805
 806
 807 void
 808 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 809 {
 810   write_float (dtp, f, p, len);
 811 }
 812
 813
 814 /* Take care of the X/TR descriptor.  */
 815
 816 void
 817 write_x (st_parameter_dt *dtp, int len, int nspaces)
 818 {
 819   char *p;
 820
 821   p = write_block (dtp, len);
 822   if (p == NULL)
 823     return;
 824   if (nspaces > 0 && len - nspaces >= 0)
 825     memset (&p[len - nspaces], ' ', nspaces);
 826 }
 827
 828
 829 /* List-directed writing.  */
 830
 831
 832 /* Write a single character to the output.  Returns nonzero if
 833    something goes wrong.  */
 834
 835 static int
 836 write_char (st_parameter_dt *dtp, char c)
 837 {
 838   char *p;
 839
 840   p = write_block (dtp, 1);
 841   if (p == NULL)
 842     return 1;
 843
 844   *p = c;
 845
 846   return 0;
 847 }
 848
 849
 850 /* Write a list-directed logical value.  */
 851
 852 static void
 853 write_logical (st_parameter_dt *dtp, const char *source, int length)
 854 {
 855   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
 856 }
 857
 858
 859 /* Write a list-directed integer value.  */
 860
 861 static void
 862 write_integer (st_parameter_dt *dtp, const char *source, int length)
 863 {
 864   char *p;
 865   const char *q;
 866   int digits;
 867   int width;
 868   char itoa_buf[GFC_ITOA_BUF_SIZE];
 869
 870   q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
 871
 872   switch (length)
 873     {
 874     case 1:
 875       width = 4;
 876       break;
 877
 878     case 2:
 879       width = 6;
 880       break;
 881
 882     case 4:
 883       width = 11;
 884       break;
 885
 886     case 8:
 887       width = 20;
 888       break;
 889
 890     default:
 891       width = 0;
 892       break;
 893     }
 894
 895   digits = strlen (q);
 896
 897   if (width < digits)
 898     width = digits;
 899   p = write_block (dtp, width);
 900   if (p == NULL)
 901     return;
 902   if (dtp->u.p.no_leading_blank)
 903     {
 904       memcpy (p, q, digits);
 905       memset (p + digits, ' ', width - digits);
 906     }
 907   else
 908     {
 909       memset (p, ' ', width - digits);
 910       memcpy (p + width - digits, q, digits);
 911     }
 912 }
 913
 914
 915 /* Write a list-directed string.  We have to worry about delimiting
 916    the strings if the file has been opened in that mode.  */
 917
 918 static void
 919 write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 920 {
 921   int i, extra;
 922   char *p, d;
 923
 924   switch (dtp->u.p.current_unit->delim_status)
 925     {
 926     case DELIM_APOSTROPHE:
 927       d = '\'';
 928       break;
 929     case DELIM_QUOTE:
 930       d = '"';
 931       break;
 932     default:
 933       d = ' ';
 934       break;
 935     }
 936
 937   if (kind == 1)
 938     {
 939       if (d == ' ')
 940         extra = 0;
 941       else
 942         {
 943           extra = 2;
 944
 945           for (i = 0; i < length; i++)
 946             if (source[i] == d)
 947               extra++;
 948         }
 949
 950       p = write_block (dtp, length + extra);
 951       if (p == NULL)
 952         return;
 953
 954       if (d == ' ')
 955         memcpy (p, source, length);
 956       else
 957         {
 958           *p++ = d;
 959
 960           for (i = 0; i < length; i++)
 961             {
 962               *p++ = source[i];
 963               if (source[i] == d)
 964                 *p++ = d;
 965             }
 966
 967           *p = d;
 968         }
 969     }
 970   else
 971     {
 972       if (d == ' ')
 973         {
 974           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 975             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
 976           else
 977             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
 978         }
 979       else
 980         {
 981           p = write_block (dtp, 1);
 982           *p = d;
 983
 984           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 985             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
 986           else
 987             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
 988
 989           p = write_block (dtp, 1);
 990           *p = d;
 991         }
 992     }
 993 }
 994
 995
 996 /* Set an fnode to default format.  */
 997
 998 static void
 999 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1000 {
1001   f->format = FMT_G;
1002   switch (length)
1003     {
1004     case 4:
1005       f->u.real.w = 15;
1006       f->u.real.d = 8;
1007       f->u.real.e = 2;
1008       break;
1009     case 8:
1010       f->u.real.w = 25;
1011       f->u.real.d = 17;
1012       f->u.real.e = 3;
1013       break;
1014     case 10:
1015       f->u.real.w = 29;
1016       f->u.real.d = 20;
1017       f->u.real.e = 4;
1018       break;
1019     case 16:
1020       f->u.real.w = 44;
1021       f->u.real.d = 35;
1022       f->u.real.e = 4;
1023       break;
1024     default:
1025       internal_error (&dtp->common, "bad real kind");
1026       break;
1027     }
1028 }
1029 /* Output a real number with default format.
1030    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1031    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
1032
1033 void
1034 write_real (st_parameter_dt *dtp, const char *source, int length)
1035 {
1036   fnode f ;
1037   int org_scale = dtp->u.p.scale_factor;
1038   dtp->u.p.scale_factor = 1;
1039   set_fnode_default (dtp, &f, length);
1040   write_float (dtp, &f, source , length);
1041   dtp->u.p.scale_factor = org_scale;
1042 }
1043
1044
1045 void
1046 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1047 {
1048   fnode f ;
1049   set_fnode_default (dtp, &f, length);
1050   if (d > 0)
1051     f.u.real.d = d;
1052   dtp->u.p.g0_no_blanks = 1;
1053   write_float (dtp, &f, source , length);
1054   dtp->u.p.g0_no_blanks = 0;
1055 }
1056
1057
1058 static void
1059 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1060 {
1061   char semi_comma =
1062         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1063
1064   if (write_char (dtp, '('))
1065     return;
1066   write_real (dtp, source, kind);
1067
1068   if (write_char (dtp, semi_comma))
1069     return;
1070   write_real (dtp, source + size / 2, kind);
1071
1072   write_char (dtp, ')');
1073 }
1074
1075
1076 /* Write the separator between items.  */
1077
1078 static void
1079 write_separator (st_parameter_dt *dtp)
1080 {
1081   char *p;
1082
1083   p = write_block (dtp, options.separator_len);
1084   if (p == NULL)
1085     return;
1086
1087   memcpy (p, options.separator, options.separator_len);
1088 }
1089
1090
1091 /* Write an item with list formatting.
1092    TODO: handle skipping to the next record correctly, particularly
1093    with strings.  */
1094
1095 static void
1096 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1097                              size_t size)
1098 {
1099   if (dtp->u.p.current_unit == NULL)
1100     return;
1101
1102   if (dtp->u.p.first_item)
1103     {
1104       dtp->u.p.first_item = 0;
1105       write_char (dtp, ' ');
1106     }
1107   else
1108     {
1109       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1110         dtp->u.p.current_unit->delim_status != DELIM_NONE)
1111       write_separator (dtp);
1112     }
1113
1114   switch (type)
1115     {
1116     case BT_INTEGER:
1117       write_integer (dtp, p, kind);
1118       break;
1119     case BT_LOGICAL:
1120       write_logical (dtp, p, kind);
1121       break;
1122     case BT_CHARACTER:
1123       write_character (dtp, p, kind, size);
1124       break;
1125     case BT_REAL:
1126       write_real (dtp, p, kind);
1127       break;
1128     case BT_COMPLEX:
1129       write_complex (dtp, p, kind, size);
1130       break;
1131     default:
1132       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1133     }
1134
1135   dtp->u.p.char_flag = (type == BT_CHARACTER);
1136 }
1137
1138
1139 void
1140 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1141                       size_t size, size_t nelems)
1142 {
1143   size_t elem;
1144   char *tmp;
1145   size_t stride = type == BT_CHARACTER ?
1146                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1147
1148   tmp = (char *) p;
1149
1150   /* Big loop over all the elements.  */
1151   for (elem = 0; elem < nelems; elem++)
1152     {
1153       dtp->u.p.item_count++;
1154       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1155     }
1156 }
1157
1158 /*                      NAMELIST OUTPUT
1159
1160    nml_write_obj writes a namelist object to the output stream.  It is called
1161    recursively for derived type components:
1162         obj    = is the namelist_info for the current object.
1163         offset = the offset relative to the address held by the object for
1164                  derived type arrays.
1165         base   = is the namelist_info of the derived type, when obj is a
1166                  component.
1167         base_name = the full name for a derived type, including qualifiers
1168                     if any.
1169    The returned value is a pointer to the object beyond the last one
1170    accessed, including nested derived types.  Notice that the namelist is
1171    a linear linked list of objects, including derived types and their
1172    components.  A tree, of sorts, is implied by the compound names of
1173    the derived type components and this is how this function recurses through
1174    the list.  */
1175
1176 /* A generous estimate of the number of characters needed to print
1177    repeat counts and indices, including commas, asterices and brackets.  */
1178
1179 #define NML_DIGITS 20
1180
1181 static void
1182 namelist_write_newline (st_parameter_dt *dtp)
1183 {
1184   if (!is_internal_unit (dtp))
1185     {
1186 #ifdef HAVE_CRLF
1187       write_character (dtp, "\r\n", 1, 2);
1188 #else
1189       write_character (dtp, "\n", 1, 1);
1190 #endif
1191       return;
1192     }
1193
1194   if (is_array_io (dtp))
1195     {
1196       gfc_offset record;
1197       int finished, length;
1198
1199       length = (int) dtp->u.p.current_unit->bytes_left;
1200
1201       /* Now that the current record has been padded out,
1202          determine where the next record in the array is. */
1203       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1204                                   &finished);
1205       if (finished)
1206         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1207       else
1208         {
1209           /* Now seek to this record */
1210           record = record * dtp->u.p.current_unit->recl;
1211
1212           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1213             {
1214               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1215               return;
1216             }
1217
1218           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1219         }
1220     }
1221   else
1222     write_character (dtp, " ", 1, 1);
1223 }
1224
1225
1226 static namelist_info *
1227 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1228                namelist_info * base, char * base_name)
1229 {
1230   int rep_ctr;
1231   int num;
1232   int nml_carry;
1233   int len;
1234   index_type obj_size;
1235   index_type nelem;
1236   size_t dim_i;
1237   size_t clen;
1238   index_type elem_ctr;
1239   size_t obj_name_len;
1240   void * p ;
1241   char cup;
1242   char * obj_name;
1243   char * ext_name;
1244   char rep_buff[NML_DIGITS];
1245   namelist_info * cmp;
1246   namelist_info * retval = obj->next;
1247   size_t base_name_len;
1248   size_t base_var_name_len;
1249   size_t tot_len;
1250   unit_delim tmp_delim;
1251
1252   /* Set the character to be used to separate values
1253      to a comma or semi-colon.  */
1254
1255   char semi_comma =
1256         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1257
1258   /* Write namelist variable names in upper case. If a derived type,
1259      nothing is output.  If a component, base and base_name are set.  */
1260
1261   if (obj->type != GFC_DTYPE_DERIVED)
1262     {
1263       namelist_write_newline (dtp);
1264       write_character (dtp, " ", 1, 1);
1265
1266       len = 0;
1267       if (base)
1268         {
1269           len = strlen (base->var_name);
1270           base_name_len = strlen (base_name);
1271           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1272             {
1273               cup = toupper (base_name[dim_i]);
1274               write_character (dtp, &cup, 1, 1);
1275             }
1276         }
1277       clen = strlen (obj->var_name);
1278       for (dim_i = len; dim_i < clen; dim_i++)
1279         {
1280           cup = toupper (obj->var_name[dim_i]);
1281           write_character (dtp, &cup, 1, 1);
1282         }
1283       write_character (dtp, "=", 1, 1);
1284     }
1285
1286   /* Counts the number of data output on a line, including names.  */
1287
1288   num = 1;
1289
1290   len = obj->len;
1291
1292   switch (obj->type)
1293     {
1294
1295     case GFC_DTYPE_REAL:
1296       obj_size = size_from_real_kind (len);
1297       break;
1298
1299     case GFC_DTYPE_COMPLEX:
1300       obj_size = size_from_complex_kind (len);
1301       break;
1302
1303     case GFC_DTYPE_CHARACTER:
1304       obj_size = obj->string_length;
1305       break;
1306
1307     default:
1308       obj_size = len;
1309     }
1310
1311   if (obj->var_rank)
1312     obj_size = obj->size;
1313
1314   /* Set the index vector and count the number of elements.  */
1315
1316   nelem = 1;
1317   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1318     {
1319       obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1320       nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1321     }
1322
1323   /* Main loop to output the data held in the object.  */
1324
1325   rep_ctr = 1;
1326   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1327     {
1328
1329       /* Build the pointer to the data value.  The offset is passed by
1330          recursive calls to this function for arrays of derived types.
1331          Is NULL otherwise.  */
1332
1333       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1334       p += offset;
1335
1336       /* Check for repeat counts of intrinsic types.  */
1337
1338       if ((elem_ctr < (nelem - 1)) &&
1339           (obj->type != GFC_DTYPE_DERIVED) &&
1340           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1341         {
1342           rep_ctr++;
1343         }
1344
1345       /* Execute a repeated output.  Note the flag no_leading_blank that
1346          is used in the functions used to output the intrinsic types.  */
1347
1348       else
1349         {
1350           if (rep_ctr > 1)
1351             {
1352               sprintf(rep_buff, " %d*", rep_ctr);
1353               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1354               dtp->u.p.no_leading_blank = 1;
1355             }
1356           num++;
1357
1358           /* Output the data, if an intrinsic type, or recurse into this
1359              routine to treat derived types.  */
1360
1361           switch (obj->type)
1362             {
1363
1364             case GFC_DTYPE_INTEGER:
1365               write_integer (dtp, p, len);
1366               break;
1367
1368             case GFC_DTYPE_LOGICAL:
1369               write_logical (dtp, p, len);
1370               break;
1371
1372             case GFC_DTYPE_CHARACTER:
1373               tmp_delim = dtp->u.p.current_unit->delim_status;
1374               if (dtp->u.p.nml_delim == '"')
1375                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1376               if (dtp->u.p.nml_delim == '\'')
1377                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1378               write_character (dtp, p, 1, obj->string_length);
1379                 dtp->u.p.current_unit->delim_status = tmp_delim;
1380               break;
1381
1382             case GFC_DTYPE_REAL:
1383               write_real (dtp, p, len);
1384               break;
1385
1386            case GFC_DTYPE_COMPLEX:
1387               dtp->u.p.no_leading_blank = 0;
1388               num++;
1389               write_complex (dtp, p, len, obj_size);
1390               break;
1391
1392             case GFC_DTYPE_DERIVED:
1393
1394               /* To treat a derived type, we need to build two strings:
1395                  ext_name = the name, including qualifiers that prepends
1396                             component names in the output - passed to
1397                             nml_write_obj.
1398                  obj_name = the derived type name with no qualifiers but %
1399                             appended.  This is used to identify the
1400                             components.  */
1401
1402               /* First ext_name => get length of all possible components  */
1403
1404               base_name_len = base_name ? strlen (base_name) : 0;
1405               base_var_name_len = base ? strlen (base->var_name) : 0;
1406               ext_name = (char*)get_mem ( base_name_len
1407                                         + base_var_name_len
1408                                         + strlen (obj->var_name)
1409                                         + obj->var_rank * NML_DIGITS
1410                                         + 1);
1411
1412               memcpy (ext_name, base_name, base_name_len);
1413               clen = strlen (obj->var_name + base_var_name_len);
1414               memcpy (ext_name + base_name_len,
1415                       obj->var_name + base_var_name_len, clen);
1416
1417               /* Append the qualifier.  */
1418
1419               tot_len = base_name_len + clen;
1420               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1421                 {
1422                   if (!dim_i)
1423                     {
1424                       ext_name[tot_len] = '(';
1425                       tot_len++;
1426                     }
1427                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1428                   tot_len += strlen (ext_name + tot_len);
1429                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1430                   tot_len++;
1431                 }
1432
1433               ext_name[tot_len] = '\0';
1434
1435               /* Now obj_name.  */
1436
1437               obj_name_len = strlen (obj->var_name) + 1;
1438               obj_name = get_mem (obj_name_len+1);
1439               memcpy (obj_name, obj->var_name, obj_name_len-1);
1440               memcpy (obj_name + obj_name_len-1, "%", 2);
1441
1442               /* Now loop over the components. Update the component pointer
1443                  with the return value from nml_write_obj => this loop jumps
1444                  past nested derived types.  */
1445
1446               for (cmp = obj->next;
1447                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1448                    cmp = retval)
1449                 {
1450                   retval = nml_write_obj (dtp, cmp,
1451                                           (index_type)(p - obj->mem_pos),
1452                                           obj, ext_name);
1453                 }
1454
1455               free_mem (obj_name);
1456               free_mem (ext_name);
1457               goto obj_loop;
1458
1459             default:
1460               internal_error (&dtp->common, "Bad type for namelist write");
1461             }
1462
1463           /* Reset the leading blank suppression, write a comma (or semi-colon)
1464              and, if 5 values have been output, write a newline and advance
1465              to column 2. Reset the repeat counter.  */
1466
1467           dtp->u.p.no_leading_blank = 0;
1468           write_character (dtp, &semi_comma, 1, 1);
1469           if (num > 5)
1470             {
1471               num = 0;
1472               namelist_write_newline (dtp);
1473               write_character (dtp, " ", 1, 1);
1474             }
1475           rep_ctr = 1;
1476         }
1477
1478     /* Cycle through and increment the index vector.  */
1479
1480 obj_loop:
1481
1482     nml_carry = 1;
1483     for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1484       {
1485         obj->ls[dim_i].idx += nml_carry ;
1486         nml_carry = 0;
1487         if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
1488           {
1489             obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
1490             nml_carry = 1;
1491           }
1492        }
1493     }
1494
1495   /* Return a pointer beyond the furthest object accessed.  */
1496
1497   return retval;
1498 }
1499
1500
1501 /* This is the entry function for namelist writes.  It outputs the name
1502    of the namelist and iterates through the namelist by calls to
1503    nml_write_obj.  The call below has dummys in the arguments used in
1504    the treatment of derived types.  */
1505
1506 void
1507 namelist_write (st_parameter_dt *dtp)
1508 {
1509   namelist_info * t1, *t2, *dummy = NULL;
1510   index_type i;
1511   index_type dummy_offset = 0;
1512   char c;
1513   char * dummy_name = NULL;
1514   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1515
1516   /* Set the delimiter for namelist output.  */
1517   tmp_delim = dtp->u.p.current_unit->delim_status;
1518
1519   dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
1520
1521   /* Temporarily disable namelist delimters.  */
1522   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1523
1524   write_character (dtp, "&", 1, 1);
1525
1526   /* Write namelist name in upper case - f95 std.  */
1527   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1528     {
1529       c = toupper (dtp->namelist_name[i]);
1530       write_character (dtp, &c, 1 ,1);
1531     }
1532
1533   if (dtp->u.p.ionml != NULL)
1534     {
1535       t1 = dtp->u.p.ionml;
1536       while (t1 != NULL)
1537         {
1538           t2 = t1;
1539           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1540         }
1541     }
1542
1543   namelist_write_newline (dtp);
1544   write_character (dtp, " /", 1, 2);
1545   /* Restore the original delimiter.  */
1546   dtp->u.p.current_unit->delim_status = tmp_delim;
1547 }
1548
1549 #undef NML_DIGITS