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