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