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   set_fnode_default (dtp, &f, length);
1014   if (d > 0)
1015     f.u.real.d = d;
1016   dtp->u.p.g0_no_blanks = 1;
1017   write_float (dtp, &f, source , length);
1018   dtp->u.p.g0_no_blanks = 0;
1019 }
1020
1021
1022 static void
1023 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1024 {
1025   char semi_comma =
1026         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1027
1028   if (write_char (dtp, '('))
1029     return;
1030   write_real (dtp, source, kind);
1031
1032   if (write_char (dtp, semi_comma))
1033     return;
1034   write_real (dtp, source + size / 2, kind);
1035
1036   write_char (dtp, ')');
1037 }
1038
1039
1040 /* Write the separator between items.  */
1041
1042 static void
1043 write_separator (st_parameter_dt *dtp)
1044 {
1045   char *p;
1046
1047   p = write_block (dtp, options.separator_len);
1048   if (p == NULL)
1049     return;
1050
1051   memcpy (p, options.separator, options.separator_len);
1052 }
1053
1054
1055 /* Write an item with list formatting.
1056    TODO: handle skipping to the next record correctly, particularly
1057    with strings.  */
1058
1059 static void
1060 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1061                              size_t size)
1062 {
1063   if (dtp->u.p.current_unit == NULL)
1064     return;
1065
1066   if (dtp->u.p.first_item)
1067     {
1068       dtp->u.p.first_item = 0;
1069       write_char (dtp, ' ');
1070     }
1071   else
1072     {
1073       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1074         dtp->u.p.current_unit->delim_status != DELIM_NONE)
1075       write_separator (dtp);
1076     }
1077
1078   switch (type)
1079     {
1080     case BT_INTEGER:
1081       write_integer (dtp, p, kind);
1082       break;
1083     case BT_LOGICAL:
1084       write_logical (dtp, p, kind);
1085       break;
1086     case BT_CHARACTER:
1087       write_character (dtp, p, kind, size);
1088       break;
1089     case BT_REAL:
1090       write_real (dtp, p, kind);
1091       break;
1092     case BT_COMPLEX:
1093       write_complex (dtp, p, kind, size);
1094       break;
1095     default:
1096       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1097     }
1098
1099   dtp->u.p.char_flag = (type == BT_CHARACTER);
1100 }
1101
1102
1103 void
1104 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1105                       size_t size, size_t nelems)
1106 {
1107   size_t elem;
1108   char *tmp;
1109   size_t stride = type == BT_CHARACTER ?
1110                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1111
1112   tmp = (char *) p;
1113
1114   /* Big loop over all the elements.  */
1115   for (elem = 0; elem < nelems; elem++)
1116     {
1117       dtp->u.p.item_count++;
1118       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1119     }
1120 }
1121
1122 /*                      NAMELIST OUTPUT
1123
1124    nml_write_obj writes a namelist object to the output stream.  It is called
1125    recursively for derived type components:
1126         obj    = is the namelist_info for the current object.
1127         offset = the offset relative to the address held by the object for
1128                  derived type arrays.
1129         base   = is the namelist_info of the derived type, when obj is a
1130                  component.
1131         base_name = the full name for a derived type, including qualifiers
1132                     if any.
1133    The returned value is a pointer to the object beyond the last one
1134    accessed, including nested derived types.  Notice that the namelist is
1135    a linear linked list of objects, including derived types and their
1136    components.  A tree, of sorts, is implied by the compound names of
1137    the derived type components and this is how this function recurses through
1138    the list.  */
1139
1140 /* A generous estimate of the number of characters needed to print
1141    repeat counts and indices, including commas, asterices and brackets.  */
1142
1143 #define NML_DIGITS 20
1144
1145 static void
1146 namelist_write_newline (st_parameter_dt *dtp)
1147 {
1148   if (!is_internal_unit (dtp))
1149     {
1150 #ifdef HAVE_CRLF
1151       write_character (dtp, "\r\n", 1, 2);
1152 #else
1153       write_character (dtp, "\n", 1, 1);
1154 #endif
1155       return;
1156     }
1157
1158   if (is_array_io (dtp))
1159     {
1160       gfc_offset record;
1161       int finished, length;
1162
1163       length = (int) dtp->u.p.current_unit->bytes_left;
1164
1165       /* Now that the current record has been padded out,
1166          determine where the next record in the array is. */
1167       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1168                                   &finished);
1169       if (finished)
1170         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1171       else
1172         {
1173           /* Now seek to this record */
1174           record = record * dtp->u.p.current_unit->recl;
1175
1176           if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1177             {
1178               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1179               return;
1180             }
1181
1182           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1183         }
1184     }
1185   else
1186     write_character (dtp, " ", 1, 1);
1187 }
1188
1189
1190 static namelist_info *
1191 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1192                namelist_info * base, char * base_name)
1193 {
1194   int rep_ctr;
1195   int num;
1196   int nml_carry;
1197   index_type len;
1198   index_type obj_size;
1199   index_type nelem;
1200   index_type dim_i;
1201   index_type clen;
1202   index_type elem_ctr;
1203   index_type obj_name_len;
1204   void * p ;
1205   char cup;
1206   char * obj_name;
1207   char * ext_name;
1208   char rep_buff[NML_DIGITS];
1209   namelist_info * cmp;
1210   namelist_info * retval = obj->next;
1211   size_t base_name_len;
1212   size_t base_var_name_len;
1213   size_t tot_len;
1214   unit_delim tmp_delim;
1215
1216   /* Set the character to be used to separate values
1217      to a comma or semi-colon.  */
1218
1219   char semi_comma =
1220         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1221
1222   /* Write namelist variable names in upper case. If a derived type,
1223      nothing is output.  If a component, base and base_name are set.  */
1224
1225   if (obj->type != GFC_DTYPE_DERIVED)
1226     {
1227       namelist_write_newline (dtp);
1228       write_character (dtp, " ", 1, 1);
1229
1230       len = 0;
1231       if (base)
1232         {
1233           len =strlen (base->var_name);
1234           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1235             {
1236               cup = toupper (base_name[dim_i]);
1237               write_character (dtp, &cup, 1, 1);
1238             }
1239         }
1240       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1241         {
1242           cup = toupper (obj->var_name[dim_i]);
1243           write_character (dtp, &cup, 1, 1);
1244         }
1245       write_character (dtp, "=", 1, 1);
1246     }
1247
1248   /* Counts the number of data output on a line, including names.  */
1249
1250   num = 1;
1251
1252   len = obj->len;
1253
1254   switch (obj->type)
1255     {
1256
1257     case GFC_DTYPE_REAL:
1258       obj_size = size_from_real_kind (len);
1259       break;
1260
1261     case GFC_DTYPE_COMPLEX:
1262       obj_size = size_from_complex_kind (len);
1263       break;
1264
1265     case GFC_DTYPE_CHARACTER:
1266       obj_size = obj->string_length;
1267       break;
1268
1269     default:
1270       obj_size = len;
1271     }
1272
1273   if (obj->var_rank)
1274     obj_size = obj->size;
1275
1276   /* Set the index vector and count the number of elements.  */
1277
1278   nelem = 1;
1279   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1280     {
1281       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1282       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1283     }
1284
1285   /* Main loop to output the data held in the object.  */
1286
1287   rep_ctr = 1;
1288   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1289     {
1290
1291       /* Build the pointer to the data value.  The offset is passed by
1292          recursive calls to this function for arrays of derived types.
1293          Is NULL otherwise.  */
1294
1295       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1296       p += offset;
1297
1298       /* Check for repeat counts of intrinsic types.  */
1299
1300       if ((elem_ctr < (nelem - 1)) &&
1301           (obj->type != GFC_DTYPE_DERIVED) &&
1302           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1303         {
1304           rep_ctr++;
1305         }
1306
1307       /* Execute a repeated output.  Note the flag no_leading_blank that
1308          is used in the functions used to output the intrinsic types.  */
1309
1310       else
1311         {
1312           if (rep_ctr > 1)
1313             {
1314               sprintf(rep_buff, " %d*", rep_ctr);
1315               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1316               dtp->u.p.no_leading_blank = 1;
1317             }
1318           num++;
1319
1320           /* Output the data, if an intrinsic type, or recurse into this
1321              routine to treat derived types.  */
1322
1323           switch (obj->type)
1324             {
1325
1326             case GFC_DTYPE_INTEGER:
1327               write_integer (dtp, p, len);
1328               break;
1329
1330             case GFC_DTYPE_LOGICAL:
1331               write_logical (dtp, p, len);
1332               break;
1333
1334             case GFC_DTYPE_CHARACTER:
1335               tmp_delim = dtp->u.p.current_unit->delim_status;
1336               if (dtp->u.p.nml_delim == '"')
1337                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1338               if (dtp->u.p.nml_delim == '\'')
1339                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1340               write_character (dtp, p, 1, obj->string_length);
1341                 dtp->u.p.current_unit->delim_status = tmp_delim;
1342               break;
1343
1344             case GFC_DTYPE_REAL:
1345               write_real (dtp, p, len);
1346               break;
1347
1348            case GFC_DTYPE_COMPLEX:
1349               dtp->u.p.no_leading_blank = 0;
1350               num++;
1351               write_complex (dtp, p, len, obj_size);
1352               break;
1353
1354             case GFC_DTYPE_DERIVED:
1355
1356               /* To treat a derived type, we need to build two strings:
1357                  ext_name = the name, including qualifiers that prepends
1358                             component names in the output - passed to
1359                             nml_write_obj.
1360                  obj_name = the derived type name with no qualifiers but %
1361                             appended.  This is used to identify the
1362                             components.  */
1363
1364               /* First ext_name => get length of all possible components  */
1365
1366               base_name_len = base_name ? strlen (base_name) : 0;
1367               base_var_name_len = base ? strlen (base->var_name) : 0;
1368               ext_name = (char*)get_mem ( base_name_len
1369                                         + base_var_name_len
1370                                         + strlen (obj->var_name)
1371                                         + obj->var_rank * NML_DIGITS
1372                                         + 1);
1373
1374               memcpy (ext_name, base_name, base_name_len);
1375               clen = strlen (obj->var_name + base_var_name_len);
1376               memcpy (ext_name + base_name_len,
1377                       obj->var_name + base_var_name_len, clen);
1378
1379               /* Append the qualifier.  */
1380
1381               tot_len = base_name_len + clen;
1382               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1383                 {
1384                   if (!dim_i)
1385                     {
1386                       ext_name[tot_len] = '(';
1387                       tot_len++;
1388                     }
1389                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1390                   tot_len += strlen (ext_name + tot_len);
1391                   ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1392                   tot_len++;
1393                 }
1394
1395               ext_name[tot_len] = '\0';
1396
1397               /* Now obj_name.  */
1398
1399               obj_name_len = strlen (obj->var_name) + 1;
1400               obj_name = get_mem (obj_name_len+1);
1401               memcpy (obj_name, obj->var_name, obj_name_len-1);
1402               memcpy (obj_name + obj_name_len-1, "%", 2);
1403
1404               /* Now loop over the components. Update the component pointer
1405                  with the return value from nml_write_obj => this loop jumps
1406                  past nested derived types.  */
1407
1408               for (cmp = obj->next;
1409                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1410                    cmp = retval)
1411                 {
1412                   retval = nml_write_obj (dtp, cmp,
1413                                           (index_type)(p - obj->mem_pos),
1414                                           obj, ext_name);
1415                 }
1416
1417               free_mem (obj_name);
1418               free_mem (ext_name);
1419               goto obj_loop;
1420
1421             default:
1422               internal_error (&dtp->common, "Bad type for namelist write");
1423             }
1424
1425           /* Reset the leading blank suppression, write a comma (or semi-colon)
1426              and, if 5 values have been output, write a newline and advance
1427              to column 2. Reset the repeat counter.  */
1428
1429           dtp->u.p.no_leading_blank = 0;
1430           write_character (dtp, &semi_comma, 1, 1);
1431           if (num > 5)
1432             {
1433               num = 0;
1434               namelist_write_newline (dtp);
1435               write_character (dtp, " ", 1, 1);
1436             }
1437           rep_ctr = 1;
1438         }
1439
1440     /* Cycle through and increment the index vector.  */
1441
1442 obj_loop:
1443
1444     nml_carry = 1;
1445     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1446       {
1447         obj->ls[dim_i].idx += nml_carry ;
1448         nml_carry = 0;
1449         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1450           {
1451             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1452             nml_carry = 1;
1453           }
1454        }
1455     }
1456
1457   /* Return a pointer beyond the furthest object accessed.  */
1458
1459   return retval;
1460 }
1461
1462
1463 /* This is the entry function for namelist writes.  It outputs the name
1464    of the namelist and iterates through the namelist by calls to
1465    nml_write_obj.  The call below has dummys in the arguments used in
1466    the treatment of derived types.  */
1467
1468 void
1469 namelist_write (st_parameter_dt *dtp)
1470 {
1471   namelist_info * t1, *t2, *dummy = NULL;
1472   index_type i;
1473   index_type dummy_offset = 0;
1474   char c;
1475   char * dummy_name = NULL;
1476   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1477
1478   /* Set the delimiter for namelist output.  */
1479   tmp_delim = dtp->u.p.current_unit->delim_status;
1480
1481   dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
1482
1483   /* Temporarily disable namelist delimters.  */
1484   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1485
1486   write_character (dtp, "&", 1, 1);
1487
1488   /* Write namelist name in upper case - f95 std.  */
1489   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1490     {
1491       c = toupper (dtp->namelist_name[i]);
1492       write_character (dtp, &c, 1 ,1);
1493     }
1494
1495   if (dtp->u.p.ionml != NULL)
1496     {
1497       t1 = dtp->u.p.ionml;
1498       while (t1 != NULL)
1499         {
1500           t2 = t1;
1501           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1502         }
1503     }
1504
1505   namelist_write_newline (dtp);
1506   write_character (dtp, " /", 1, 2);
1507   /* Restore the original delimiter.  */
1508   dtp->u.p.current_unit->delim_status = tmp_delim;
1509 }
1510
1511 #undef NML_DIGITS