libgfortran/io/write.c

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