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