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     }
1150   else
1151     write_character (dtp, " ", 1, 1);
1152 }
1153
1154
1155 static namelist_info *
1156 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1157                namelist_info * base, char * base_name)
1158 {
1159   int rep_ctr;
1160   int num;
1161   int nml_carry;
1162   index_type len;
1163   index_type obj_size;
1164   index_type nelem;
1165   index_type dim_i;
1166   index_type clen;
1167   index_type elem_ctr;
1168   index_type obj_name_len;
1169   void * p ;
1170   char cup;
1171   char * obj_name;
1172   char * ext_name;
1173   char rep_buff[NML_DIGITS];
1174   namelist_info * cmp;
1175   namelist_info * retval = obj->next;
1176   size_t base_name_len;
1177   size_t base_var_name_len;
1178   size_t tot_len;
1179   unit_delim tmp_delim;
1180
1181   /* Set the character to be used to separate values
1182      to a comma or semi-colon.  */
1183
1184   char semi_comma =
1185         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1186
1187   /* Write namelist variable names in upper case. If a derived type,
1188      nothing is output.  If a component, base and base_name are set.  */
1189
1190   if (obj->type != GFC_DTYPE_DERIVED)
1191     {
1192       namelist_write_newline (dtp);
1193       write_character (dtp, " ", 1, 1);
1194
1195       len = 0;
1196       if (base)
1197         {
1198           len =strlen (base->var_name);
1199           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1200             {
1201               cup = toupper (base_name[dim_i]);
1202               write_character (dtp, &cup, 1, 1);
1203             }
1204         }
1205       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1206         {
1207           cup = toupper (obj->var_name[dim_i]);
1208           write_character (dtp, &cup, 1, 1);
1209         }
1210       write_character (dtp, "=", 1, 1);
1211     }
1212
1213   /* Counts the number of data output on a line, including names.  */
1214
1215   num = 1;
1216
1217   len = obj->len;
1218
1219   switch (obj->type)
1220     {
1221
1222     case GFC_DTYPE_REAL:
1223       obj_size = size_from_real_kind (len);
1224       break;
1225
1226     case GFC_DTYPE_COMPLEX:
1227       obj_size = size_from_complex_kind (len);
1228       break;
1229
1230     case GFC_DTYPE_CHARACTER:
1231       obj_size = obj->string_length;
1232       break;
1233
1234     default:
1235       obj_size = len;
1236     }
1237
1238   if (obj->var_rank)
1239     obj_size = obj->size;
1240
1241   /* Set the index vector and count the number of elements.  */
1242
1243   nelem = 1;
1244   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1245     {
1246       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1247       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1248     }
1249
1250   /* Main loop to output the data held in the object.  */
1251
1252   rep_ctr = 1;
1253   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1254     {
1255
1256       /* Build the pointer to the data value.  The offset is passed by
1257          recursive calls to this function for arrays of derived types.
1258          Is NULL otherwise.  */
1259
1260       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1261       p += offset;
1262
1263       /* Check for repeat counts of intrinsic types.  */
1264
1265       if ((elem_ctr < (nelem - 1)) &&
1266           (obj->type != GFC_DTYPE_DERIVED) &&
1267           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1268         {
1269           rep_ctr++;
1270         }
1271
1272       /* Execute a repeated output.  Note the flag no_leading_blank that
1273          is used in the functions used to output the intrinsic types.  */
1274
1275       else
1276         {
1277           if (rep_ctr > 1)
1278             {
1279               sprintf(rep_buff, " %d*", rep_ctr);
1280               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1281               dtp->u.p.no_leading_blank = 1;
1282             }
1283           num++;
1284
1285           /* Output the data, if an intrinsic type, or recurse into this
1286              routine to treat derived types.  */
1287
1288           switch (obj->type)
1289             {
1290
1291             case GFC_DTYPE_INTEGER:
1292               write_integer (dtp, p, len);
1293               break;
1294
1295             case GFC_DTYPE_LOGICAL:
1296               write_logical (dtp, p, len);
1297               break;
1298
1299             case GFC_DTYPE_CHARACTER:
1300               tmp_delim = dtp->u.p.current_unit->delim_status;
1301               if (dtp->u.p.nml_delim == '"')
1302                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1303               if (dtp->u.p.nml_delim == '\'')
1304                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1305               write_character (dtp, p, 1, obj->string_length);
1306                 dtp->u.p.current_unit->delim_status = tmp_delim;
1307               break;
1308
1309             case GFC_DTYPE_REAL:
1310               write_real (dtp, p, len);
1311               break;
1312
1313            case GFC_DTYPE_COMPLEX:
1314               dtp->u.p.no_leading_blank = 0;
1315               num++;
1316               write_complex (dtp, p, len, obj_size);
1317               break;
1318
1319             case GFC_DTYPE_DERIVED:
1320
1321               /* To treat a derived type, we need to build two strings:
1322                  ext_name = the name, including qualifiers that prepends
1323                             component names in the output - passed to
1324                             nml_write_obj.
1325                  obj_name = the derived type name with no qualifiers but %
1326                             appended.  This is used to identify the
1327                             components.  */
1328
1329               /* First ext_name => get length of all possible components  */
1330
1331               base_name_len = base_name ? strlen (base_name) : 0;
1332               base_var_name_len = base ? strlen (base->var_name) : 0;
1333               ext_name = (char*)get_mem ( base_name_len
1334                                         + base_var_name_len
1335                                         + strlen (obj->var_name)
1336                                         + obj->var_rank * NML_DIGITS
1337                                         + 1);
1338
1339               memcpy (ext_name, base_name, base_name_len);
1340               clen = strlen (obj->var_name + base_var_name_len);
1341               memcpy (ext_name + base_name_len,
1342                       obj->var_name + base_var_name_len, clen);
1343
1344               /* Append the qualifier.  */
1345
1346               tot_len = base_name_len + clen;
1347               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1348                 {
1349                   if (!dim_i)
1350                     {
1351                       ext_name[tot_len] = '(';
1352                       tot_len++;
1353                     }
1354                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1355                   tot_len += strlen (ext_name + tot_len);
1356                   ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1357                   tot_len++;
1358                 }
1359
1360               ext_name[tot_len] = '\0';
1361
1362               /* Now obj_name.  */
1363
1364               obj_name_len = strlen (obj->var_name) + 1;
1365               obj_name = get_mem (obj_name_len+1);
1366               memcpy (obj_name, obj->var_name, obj_name_len-1);
1367               memcpy (obj_name + obj_name_len-1, "%", 2);
1368
1369               /* Now loop over the components. Update the component pointer
1370                  with the return value from nml_write_obj => this loop jumps
1371                  past nested derived types.  */
1372
1373               for (cmp = obj->next;
1374                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1375                    cmp = retval)
1376                 {
1377                   retval = nml_write_obj (dtp, cmp,
1378                                           (index_type)(p - obj->mem_pos),
1379                                           obj, ext_name);
1380                 }
1381
1382               free_mem (obj_name);
1383               free_mem (ext_name);
1384               goto obj_loop;
1385
1386             default:
1387               internal_error (&dtp->common, "Bad type for namelist write");
1388             }
1389
1390           /* Reset the leading blank suppression, write a comma (or semi-colon)
1391              and, if 5 values have been output, write a newline and advance
1392              to column 2. Reset the repeat counter.  */
1393
1394           dtp->u.p.no_leading_blank = 0;
1395           write_character (dtp, &semi_comma, 1, 1);
1396           if (num > 5)
1397             {
1398               num = 0;
1399               namelist_write_newline (dtp);
1400               write_character (dtp, " ", 1, 1);
1401             }
1402           rep_ctr = 1;
1403         }
1404
1405     /* Cycle through and increment the index vector.  */
1406
1407 obj_loop:
1408
1409     nml_carry = 1;
1410     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1411       {
1412         obj->ls[dim_i].idx += nml_carry ;
1413         nml_carry = 0;
1414         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1415           {
1416             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1417             nml_carry = 1;
1418           }
1419        }
1420     }
1421
1422   /* Return a pointer beyond the furthest object accessed.  */
1423
1424   return retval;
1425 }
1426
1427
1428 /* This is the entry function for namelist writes.  It outputs the name
1429    of the namelist and iterates through the namelist by calls to
1430    nml_write_obj.  The call below has dummys in the arguments used in
1431    the treatment of derived types.  */
1432
1433 void
1434 namelist_write (st_parameter_dt *dtp)
1435 {
1436   namelist_info * t1, *t2, *dummy = NULL;
1437   index_type i;
1438   index_type dummy_offset = 0;
1439   char c;
1440   char * dummy_name = NULL;
1441   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1442
1443   /* Set the delimiter for namelist output.  */
1444   tmp_delim = dtp->u.p.current_unit->delim_status;
1445   switch (tmp_delim)
1446     {
1447     case (DELIM_QUOTE):
1448       dtp->u.p.nml_delim = '"';
1449       break;
1450
1451     case (DELIM_APOSTROPHE):
1452       dtp->u.p.nml_delim = '\'';
1453       break;
1454
1455     default:
1456       dtp->u.p.nml_delim = '\0';
1457       break;
1458     }
1459
1460   /* Temporarily disable namelist delimters.  */
1461   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1462
1463   write_character (dtp, "&", 1, 1);
1464
1465   /* Write namelist name in upper case - f95 std.  */
1466   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1467     {
1468       c = toupper (dtp->namelist_name[i]);
1469       write_character (dtp, &c, 1 ,1);
1470     }
1471
1472   if (dtp->u.p.ionml != NULL)
1473     {
1474       t1 = dtp->u.p.ionml;
1475       while (t1 != NULL)
1476         {
1477           t2 = t1;
1478           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1479         }
1480     }
1481
1482   write_character (dtp, "  /", 1, 3);
1483   namelist_write_newline (dtp);
1484   /* Restore the original delimiter.  */
1485   dtp->u.p.current_unit->delim_status = tmp_delim;
1486 }
1487
1488 #undef NML_DIGITS