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 /* itoa()-- Integer to decimal conversion. */
 711
 712 static const char *
 713 itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
 714 {
 715   int negative;
 716   char *p;
 717   GFC_UINTEGER_LARGEST t;
 718
 719   assert (len >= GFC_ITOA_BUF_SIZE);
 720
 721   if (n == 0)
 722     return "0";
 723
 724   negative = 0;
 725   t = n;
 726   if (n < 0)
 727     {
 728       negative = 1;
 729       t = -n; /*must use unsigned to protect from overflow*/
 730     }
 731
 732   p = buffer + GFC_ITOA_BUF_SIZE - 1;
 733   *p = '\0';
 734
 735   while (t != 0)
 736     {
 737       *--p = '0' + (t % 10);
 738       t /= 10;
 739     }
 740
 741   if (negative)
 742     *--p = '-';
 743   return p;
 744 }
 745
 746
 747 void
 748 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 749 {
 750   write_decimal (dtp, f, p, len, (void *) itoa);
 751 }
 752
 753
 754 void
 755 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 756 {
 757   write_int (dtp, f, p, len, btoa);
 758 }
 759
 760
 761 void
 762 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 763 {
 764   write_int (dtp, f, p, len, otoa);
 765 }
 766
 767 void
 768 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 769 {
 770   write_int (dtp, f, p, len, gfc_xtoa);
 771 }
 772
 773
 774 void
 775 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 776 {
 777   write_float (dtp, f, p, len);
 778 }
 779
 780
 781 void
 782 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 783 {
 784   write_float (dtp, f, p, len);
 785 }
 786
 787
 788 void
 789 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 790 {
 791   write_float (dtp, f, p, len);
 792 }
 793
 794
 795 void
 796 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 797 {
 798   write_float (dtp, f, p, len);
 799 }
 800
 801
 802 void
 803 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 804 {
 805   write_float (dtp, f, p, len);
 806 }
 807
 808
 809 /* Take care of the X/TR descriptor.  */
 810
 811 void
 812 write_x (st_parameter_dt *dtp, int len, int nspaces)
 813 {
 814   char *p;
 815
 816   p = write_block (dtp, len);
 817   if (p == NULL)
 818     return;
 819   if (nspaces > 0 && len - nspaces >= 0)
 820     memset (&p[len - nspaces], ' ', nspaces);
 821 }
 822
 823
 824 /* List-directed writing.  */
 825
 826
 827 /* Write a single character to the output.  Returns nonzero if
 828    something goes wrong.  */
 829
 830 static int
 831 write_char (st_parameter_dt *dtp, char c)
 832 {
 833   char *p;
 834
 835   p = write_block (dtp, 1);
 836   if (p == NULL)
 837     return 1;
 838
 839   *p = c;
 840
 841   return 0;
 842 }
 843
 844
 845 /* Write a list-directed logical value.  */
 846
 847 static void
 848 write_logical (st_parameter_dt *dtp, const char *source, int length)
 849 {
 850   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
 851 }
 852
 853
 854 /* Write a list-directed integer value.  */
 855
 856 static void
 857 write_integer (st_parameter_dt *dtp, const char *source, int length)
 858 {
 859   char *p;
 860   const char *q;
 861   int digits;
 862   int width;
 863   char itoa_buf[GFC_ITOA_BUF_SIZE];
 864
 865   q = itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
 866
 867   switch (length)
 868     {
 869     case 1:
 870       width = 4;
 871       break;
 872
 873     case 2:
 874       width = 6;
 875       break;
 876
 877     case 4:
 878       width = 11;
 879       break;
 880
 881     case 8:
 882       width = 20;
 883       break;
 884
 885     default:
 886       width = 0;
 887       break;
 888     }
 889
 890   digits = strlen (q);
 891
 892   if (width < digits)
 893     width = digits;
 894   p = write_block (dtp, width);
 895   if (p == NULL)
 896     return;
 897   if (dtp->u.p.no_leading_blank)
 898     {
 899       memcpy (p, q, digits);
 900       memset (p + digits, ' ', width - digits);
 901     }
 902   else
 903     {
 904       memset (p, ' ', width - digits);
 905       memcpy (p + width - digits, q, digits);
 906     }
 907 }
 908
 909
 910 /* Write a list-directed string.  We have to worry about delimiting
 911    the strings if the file has been opened in that mode.  */
 912
 913 static void
 914 write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 915 {
 916   int i, extra;
 917   char *p, d;
 918
 919   switch (dtp->u.p.current_unit->delim_status)
 920     {
 921     case DELIM_APOSTROPHE:
 922       d = '\'';
 923       break;
 924     case DELIM_QUOTE:
 925       d = '"';
 926       break;
 927     default:
 928       d = ' ';
 929       break;
 930     }
 931
 932   if (kind == 1)
 933     {
 934       if (d == ' ')
 935         extra = 0;
 936       else
 937         {
 938           extra = 2;
 939
 940           for (i = 0; i < length; i++)
 941             if (source[i] == d)
 942               extra++;
 943         }
 944
 945       p = write_block (dtp, length + extra);
 946       if (p == NULL)
 947         return;
 948
 949       if (d == ' ')
 950         memcpy (p, source, length);
 951       else
 952         {
 953           *p++ = d;
 954
 955           for (i = 0; i < length; i++)
 956             {
 957               *p++ = source[i];
 958               if (source[i] == d)
 959                 *p++ = d;
 960             }
 961
 962           *p = d;
 963         }
 964     }
 965   else
 966     {
 967       if (d == ' ')
 968         {
 969           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 970             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
 971           else
 972             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
 973         }
 974       else
 975         {
 976           p = write_block (dtp, 1);
 977           *p = d;
 978
 979           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 980             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
 981           else
 982             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
 983
 984           p = write_block (dtp, 1);
 985           *p = d;
 986         }
 987     }
 988 }
 989
 990
 991 /* Set an fnode to default format.  */
 992
 993 static void
 994 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
 995 {
 996   f->format = FMT_G;
 997   switch (length)
 998     {
 999     case 4:
1000       f->u.real.w = 15;
1001       f->u.real.d = 8;
1002       f->u.real.e = 2;
1003       break;
1004     case 8:
1005       f->u.real.w = 25;
1006       f->u.real.d = 17;
1007       f->u.real.e = 3;
1008       break;
1009     case 10:
1010       f->u.real.w = 29;
1011       f->u.real.d = 20;
1012       f->u.real.e = 4;
1013       break;
1014     case 16:
1015       f->u.real.w = 44;
1016       f->u.real.d = 35;
1017       f->u.real.e = 4;
1018       break;
1019     default:
1020       internal_error (&dtp->common, "bad real kind");
1021       break;
1022     }
1023 }
1024 /* Output a real number with default format.
1025    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1026    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
1027
1028 void
1029 write_real (st_parameter_dt *dtp, const char *source, int length)
1030 {
1031   fnode f ;
1032   int org_scale = dtp->u.p.scale_factor;
1033   dtp->u.p.scale_factor = 1;
1034   set_fnode_default (dtp, &f, length);
1035   write_float (dtp, &f, source , length);
1036   dtp->u.p.scale_factor = org_scale;
1037 }
1038
1039
1040 void
1041 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1042 {
1043   fnode f ;
1044   set_fnode_default (dtp, &f, length);
1045   if (d > 0)
1046     f.u.real.d = d;
1047   dtp->u.p.g0_no_blanks = 1;
1048   write_float (dtp, &f, source , length);
1049   dtp->u.p.g0_no_blanks = 0;
1050 }
1051
1052
1053 static void
1054 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1055 {
1056   char semi_comma =
1057         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1058
1059   if (write_char (dtp, '('))
1060     return;
1061   write_real (dtp, source, kind);
1062
1063   if (write_char (dtp, semi_comma))
1064     return;
1065   write_real (dtp, source + size / 2, kind);
1066
1067   write_char (dtp, ')');
1068 }
1069
1070
1071 /* Write the separator between items.  */
1072
1073 static void
1074 write_separator (st_parameter_dt *dtp)
1075 {
1076   char *p;
1077
1078   p = write_block (dtp, options.separator_len);
1079   if (p == NULL)
1080     return;
1081
1082   memcpy (p, options.separator, options.separator_len);
1083 }
1084
1085
1086 /* Write an item with list formatting.
1087    TODO: handle skipping to the next record correctly, particularly
1088    with strings.  */
1089
1090 static void
1091 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1092                              size_t size)
1093 {
1094   if (dtp->u.p.current_unit == NULL)
1095     return;
1096
1097   if (dtp->u.p.first_item)
1098     {
1099       dtp->u.p.first_item = 0;
1100       write_char (dtp, ' ');
1101     }
1102   else
1103     {
1104       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1105         dtp->u.p.current_unit->delim_status != DELIM_NONE)
1106       write_separator (dtp);
1107     }
1108
1109   switch (type)
1110     {
1111     case BT_INTEGER:
1112       write_integer (dtp, p, kind);
1113       break;
1114     case BT_LOGICAL:
1115       write_logical (dtp, p, kind);
1116       break;
1117     case BT_CHARACTER:
1118       write_character (dtp, p, kind, size);
1119       break;
1120     case BT_REAL:
1121       write_real (dtp, p, kind);
1122       break;
1123     case BT_COMPLEX:
1124       write_complex (dtp, p, kind, size);
1125       break;
1126     default:
1127       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1128     }
1129
1130   dtp->u.p.char_flag = (type == BT_CHARACTER);
1131 }
1132
1133
1134 void
1135 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1136                       size_t size, size_t nelems)
1137 {
1138   size_t elem;
1139   char *tmp;
1140   size_t stride = type == BT_CHARACTER ?
1141                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1142
1143   tmp = (char *) p;
1144
1145   /* Big loop over all the elements.  */
1146   for (elem = 0; elem < nelems; elem++)
1147     {
1148       dtp->u.p.item_count++;
1149       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1150     }
1151 }
1152
1153 /*                      NAMELIST OUTPUT
1154
1155    nml_write_obj writes a namelist object to the output stream.  It is called
1156    recursively for derived type components:
1157         obj    = is the namelist_info for the current object.
1158         offset = the offset relative to the address held by the object for
1159                  derived type arrays.
1160         base   = is the namelist_info of the derived type, when obj is a
1161                  component.
1162         base_name = the full name for a derived type, including qualifiers
1163                     if any.
1164    The returned value is a pointer to the object beyond the last one
1165    accessed, including nested derived types.  Notice that the namelist is
1166    a linear linked list of objects, including derived types and their
1167    components.  A tree, of sorts, is implied by the compound names of
1168    the derived type components and this is how this function recurses through
1169    the list.  */
1170
1171 /* A generous estimate of the number of characters needed to print
1172    repeat counts and indices, including commas, asterices and brackets.  */
1173
1174 #define NML_DIGITS 20
1175
1176 static void
1177 namelist_write_newline (st_parameter_dt *dtp)
1178 {
1179   if (!is_internal_unit (dtp))
1180     {
1181 #ifdef HAVE_CRLF
1182       write_character (dtp, "\r\n", 1, 2);
1183 #else
1184       write_character (dtp, "\n", 1, 1);
1185 #endif
1186       return;
1187     }
1188
1189   if (is_array_io (dtp))
1190     {
1191       gfc_offset record;
1192       int finished, length;
1193
1194       length = (int) dtp->u.p.current_unit->bytes_left;
1195
1196       /* Now that the current record has been padded out,
1197          determine where the next record in the array is. */
1198       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1199                                   &finished);
1200       if (finished)
1201         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1202       else
1203         {
1204           /* Now seek to this record */
1205           record = record * dtp->u.p.current_unit->recl;
1206
1207           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1208             {
1209               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1210               return;
1211             }
1212
1213           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1214         }
1215     }
1216   else
1217     write_character (dtp, " ", 1, 1);
1218 }
1219
1220
1221 static namelist_info *
1222 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1223                namelist_info * base, char * base_name)
1224 {
1225   int rep_ctr;
1226   int num;
1227   int nml_carry;
1228   int len;
1229   index_type obj_size;
1230   index_type nelem;
1231   size_t dim_i;
1232   size_t clen;
1233   index_type elem_ctr;
1234   size_t obj_name_len;
1235   void * p ;
1236   char cup;
1237   char * obj_name;
1238   char * ext_name;
1239   char rep_buff[NML_DIGITS];
1240   namelist_info * cmp;
1241   namelist_info * retval = obj->next;
1242   size_t base_name_len;
1243   size_t base_var_name_len;
1244   size_t tot_len;
1245   unit_delim tmp_delim;
1246
1247   /* Set the character to be used to separate values
1248      to a comma or semi-colon.  */
1249
1250   char semi_comma =
1251         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1252
1253   /* Write namelist variable names in upper case. If a derived type,
1254      nothing is output.  If a component, base and base_name are set.  */
1255
1256   if (obj->type != GFC_DTYPE_DERIVED)
1257     {
1258       namelist_write_newline (dtp);
1259       write_character (dtp, " ", 1, 1);
1260
1261       len = 0;
1262       if (base)
1263         {
1264           len = strlen (base->var_name);
1265           base_name_len = strlen (base_name);
1266           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1267             {
1268               cup = toupper (base_name[dim_i]);
1269               write_character (dtp, &cup, 1, 1);
1270             }
1271         }
1272       clen = strlen (obj->var_name);
1273       for (dim_i = len; dim_i < clen; dim_i++)
1274         {
1275           cup = toupper (obj->var_name[dim_i]);
1276           write_character (dtp, &cup, 1, 1);
1277         }
1278       write_character (dtp, "=", 1, 1);
1279     }
1280
1281   /* Counts the number of data output on a line, including names.  */
1282
1283   num = 1;
1284
1285   len = obj->len;
1286
1287   switch (obj->type)
1288     {
1289
1290     case GFC_DTYPE_REAL:
1291       obj_size = size_from_real_kind (len);
1292       break;
1293
1294     case GFC_DTYPE_COMPLEX:
1295       obj_size = size_from_complex_kind (len);
1296       break;
1297
1298     case GFC_DTYPE_CHARACTER:
1299       obj_size = obj->string_length;
1300       break;
1301
1302     default:
1303       obj_size = len;
1304     }
1305
1306   if (obj->var_rank)
1307     obj_size = obj->size;
1308
1309   /* Set the index vector and count the number of elements.  */
1310
1311   nelem = 1;
1312   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1313     {
1314       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1315       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1316     }
1317
1318   /* Main loop to output the data held in the object.  */
1319
1320   rep_ctr = 1;
1321   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1322     {
1323
1324       /* Build the pointer to the data value.  The offset is passed by
1325          recursive calls to this function for arrays of derived types.
1326          Is NULL otherwise.  */
1327
1328       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1329       p += offset;
1330
1331       /* Check for repeat counts of intrinsic types.  */
1332
1333       if ((elem_ctr < (nelem - 1)) &&
1334           (obj->type != GFC_DTYPE_DERIVED) &&
1335           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1336         {
1337           rep_ctr++;
1338         }
1339
1340       /* Execute a repeated output.  Note the flag no_leading_blank that
1341          is used in the functions used to output the intrinsic types.  */
1342
1343       else
1344         {
1345           if (rep_ctr > 1)
1346             {
1347               sprintf(rep_buff, " %d*", rep_ctr);
1348               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1349               dtp->u.p.no_leading_blank = 1;
1350             }
1351           num++;
1352
1353           /* Output the data, if an intrinsic type, or recurse into this
1354              routine to treat derived types.  */
1355
1356           switch (obj->type)
1357             {
1358
1359             case GFC_DTYPE_INTEGER:
1360               write_integer (dtp, p, len);
1361               break;
1362
1363             case GFC_DTYPE_LOGICAL:
1364               write_logical (dtp, p, len);
1365               break;
1366
1367             case GFC_DTYPE_CHARACTER:
1368               tmp_delim = dtp->u.p.current_unit->delim_status;
1369               if (dtp->u.p.nml_delim == '"')
1370                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1371               if (dtp->u.p.nml_delim == '\'')
1372                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1373               write_character (dtp, p, 1, obj->string_length);
1374                 dtp->u.p.current_unit->delim_status = tmp_delim;
1375               break;
1376
1377             case GFC_DTYPE_REAL:
1378               write_real (dtp, p, len);
1379               break;
1380
1381            case GFC_DTYPE_COMPLEX:
1382               dtp->u.p.no_leading_blank = 0;
1383               num++;
1384               write_complex (dtp, p, len, obj_size);
1385               break;
1386
1387             case GFC_DTYPE_DERIVED:
1388
1389               /* To treat a derived type, we need to build two strings:
1390                  ext_name = the name, including qualifiers that prepends
1391                             component names in the output - passed to
1392                             nml_write_obj.
1393                  obj_name = the derived type name with no qualifiers but %
1394                             appended.  This is used to identify the
1395                             components.  */
1396
1397               /* First ext_name => get length of all possible components  */
1398
1399               base_name_len = base_name ? strlen (base_name) : 0;
1400               base_var_name_len = base ? strlen (base->var_name) : 0;
1401               ext_name = (char*)get_mem ( base_name_len
1402                                         + base_var_name_len
1403                                         + strlen (obj->var_name)
1404                                         + obj->var_rank * NML_DIGITS
1405                                         + 1);
1406
1407               memcpy (ext_name, base_name, base_name_len);
1408               clen = strlen (obj->var_name + base_var_name_len);
1409               memcpy (ext_name + base_name_len,
1410                       obj->var_name + base_var_name_len, clen);
1411
1412               /* Append the qualifier.  */
1413
1414               tot_len = base_name_len + clen;
1415               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1416                 {
1417                   if (!dim_i)
1418                     {
1419                       ext_name[tot_len] = '(';
1420                       tot_len++;
1421                     }
1422                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1423                   tot_len += strlen (ext_name + tot_len);
1424                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1425                   tot_len++;
1426                 }
1427
1428               ext_name[tot_len] = '\0';
1429
1430               /* Now obj_name.  */
1431
1432               obj_name_len = strlen (obj->var_name) + 1;
1433               obj_name = get_mem (obj_name_len+1);
1434               memcpy (obj_name, obj->var_name, obj_name_len-1);
1435               memcpy (obj_name + obj_name_len-1, "%", 2);
1436
1437               /* Now loop over the components. Update the component pointer
1438                  with the return value from nml_write_obj => this loop jumps
1439                  past nested derived types.  */
1440
1441               for (cmp = obj->next;
1442                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1443                    cmp = retval)
1444                 {
1445                   retval = nml_write_obj (dtp, cmp,
1446                                           (index_type)(p - obj->mem_pos),
1447                                           obj, ext_name);
1448                 }
1449
1450               free_mem (obj_name);
1451               free_mem (ext_name);
1452               goto obj_loop;
1453
1454             default:
1455               internal_error (&dtp->common, "Bad type for namelist write");
1456             }
1457
1458           /* Reset the leading blank suppression, write a comma (or semi-colon)
1459              and, if 5 values have been output, write a newline and advance
1460              to column 2. Reset the repeat counter.  */
1461
1462           dtp->u.p.no_leading_blank = 0;
1463           write_character (dtp, &semi_comma, 1, 1);
1464           if (num > 5)
1465             {
1466               num = 0;
1467               namelist_write_newline (dtp);
1468               write_character (dtp, " ", 1, 1);
1469             }
1470           rep_ctr = 1;
1471         }
1472
1473     /* Cycle through and increment the index vector.  */
1474
1475 obj_loop:
1476
1477     nml_carry = 1;
1478     for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1479       {
1480         obj->ls[dim_i].idx += nml_carry ;
1481         nml_carry = 0;
1482         if (obj->ls[dim_i].idx  > (index_type) obj->dim[dim_i].ubound)
1483           {
1484             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1485             nml_carry = 1;
1486           }
1487        }
1488     }
1489
1490   /* Return a pointer beyond the furthest object accessed.  */
1491
1492   return retval;
1493 }
1494
1495
1496 /* This is the entry function for namelist writes.  It outputs the name
1497    of the namelist and iterates through the namelist by calls to
1498    nml_write_obj.  The call below has dummys in the arguments used in
1499    the treatment of derived types.  */
1500
1501 void
1502 namelist_write (st_parameter_dt *dtp)
1503 {
1504   namelist_info * t1, *t2, *dummy = NULL;
1505   index_type i;
1506   index_type dummy_offset = 0;
1507   char c;
1508   char * dummy_name = NULL;
1509   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1510
1511   /* Set the delimiter for namelist output.  */
1512   tmp_delim = dtp->u.p.current_unit->delim_status;
1513
1514   dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
1515
1516   /* Temporarily disable namelist delimters.  */
1517   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1518
1519   write_character (dtp, "&", 1, 1);
1520
1521   /* Write namelist name in upper case - f95 std.  */
1522   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1523     {
1524       c = toupper (dtp->namelist_name[i]);
1525       write_character (dtp, &c, 1 ,1);
1526     }
1527
1528   if (dtp->u.p.ionml != NULL)
1529     {
1530       t1 = dtp->u.p.ionml;
1531       while (t1 != NULL)
1532         {
1533           t2 = t1;
1534           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1535         }
1536     }
1537
1538   namelist_write_newline (dtp);
1539   write_character (dtp, " /", 1, 2);
1540   /* Restore the original delimiter.  */
1541   dtp->u.p.current_unit->delim_status = tmp_delim;
1542 }
1543
1544 #undef NML_DIGITS