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 #define star_fill(p, n) memset(p, '*', n)
  40
  41 #include "write_float.def"
  42
  43 void
  44 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
  45 {
  46   int wlen;
  47   char *p;
  48
  49   wlen = f->u.string.length < 0 ? len : f->u.string.length;
  50
  51 #ifdef HAVE_CRLF
  52   /* If this is formatted STREAM IO convert any embedded line feed characters
  53      to CR_LF on systems that use that sequence for newlines.  See F2003
  54      Standard sections 10.6.3 and 9.9 for further information.  */
  55   if (is_stream_io (dtp))
  56     {
  57       const char crlf[] = "\r\n";
  58       int i, q, bytes;
  59       q = bytes = 0;
  60
  61       /* Write out any padding if needed.  */
  62       if (len < wlen)
  63         {
  64           p = write_block (dtp, wlen - len);
  65           if (p == NULL)
  66             return;
  67           memset (p, ' ', wlen - len);
  68         }
  69
  70       /* Scan the source string looking for '\n' and convert it if found.  */
  71       for (i = 0; i < wlen; i++)
  72         {
  73           if (source[i] == '\n')
  74             {
  75               /* Write out the previously scanned characters in the string.  */
  76               if (bytes > 0)
  77                 {
  78                   p = write_block (dtp, bytes);
  79                   if (p == NULL)
  80                     return;
  81                   memcpy (p, &source[q], bytes);
  82                   q += bytes;
  83                   bytes = 0;
  84                 }
  85
  86               /* Write out the CR_LF sequence.  */
  87               q++;
  88               p = write_block (dtp, 2);
  89               if (p == NULL)
  90                 return;
  91               memcpy (p, crlf, 2);
  92             }
  93           else
  94             bytes++;
  95         }
  96
  97       /*  Write out any remaining bytes if no LF was found.  */
  98       if (bytes > 0)
  99         {
 100           p = write_block (dtp, bytes);
 101           if (p == NULL)
 102             return;
 103           memcpy (p, &source[q], bytes);
 104         }
 105     }
 106   else
 107     {
 108 #endif
 109       p = write_block (dtp, wlen);
 110       if (p == NULL)
 111         return;
 112
 113       if (wlen < len)
 114         memcpy (p, source, wlen);
 115       else
 116         {
 117           memset (p, ' ', wlen - len);
 118           memcpy (p + wlen - len, source, len);
 119         }
 120 #ifdef HAVE_CRLF
 121     }
 122 #endif
 123 }
 124
 125 static GFC_INTEGER_LARGEST
 126 extract_int (const void *p, int len)
 127 {
 128   GFC_INTEGER_LARGEST i = 0;
 129
 130   if (p == NULL)
 131     return i;
 132
 133   switch (len)
 134     {
 135     case 1:
 136       {
 137         GFC_INTEGER_1 tmp;
 138         memcpy ((void *) &tmp, p, len);
 139         i = tmp;
 140       }
 141       break;
 142     case 2:
 143       {
 144         GFC_INTEGER_2 tmp;
 145         memcpy ((void *) &tmp, p, len);
 146         i = tmp;
 147       }
 148       break;
 149     case 4:
 150       {
 151         GFC_INTEGER_4 tmp;
 152         memcpy ((void *) &tmp, p, len);
 153         i = tmp;
 154       }
 155       break;
 156     case 8:
 157       {
 158         GFC_INTEGER_8 tmp;
 159         memcpy ((void *) &tmp, p, len);
 160         i = tmp;
 161       }
 162       break;
 163 #ifdef HAVE_GFC_INTEGER_16
 164     case 16:
 165       {
 166         GFC_INTEGER_16 tmp;
 167         memcpy ((void *) &tmp, p, len);
 168         i = tmp;
 169       }
 170       break;
 171 #endif
 172     default:
 173       internal_error (NULL, "bad integer kind");
 174     }
 175
 176   return i;
 177 }
 178
 179 static GFC_UINTEGER_LARGEST
 180 extract_uint (const void *p, int len)
 181 {
 182   GFC_UINTEGER_LARGEST i = 0;
 183
 184   if (p == NULL)
 185     return i;
 186
 187   switch (len)
 188     {
 189     case 1:
 190       {
 191         GFC_INTEGER_1 tmp;
 192         memcpy ((void *) &tmp, p, len);
 193         i = (GFC_UINTEGER_1) tmp;
 194       }
 195       break;
 196     case 2:
 197       {
 198         GFC_INTEGER_2 tmp;
 199         memcpy ((void *) &tmp, p, len);
 200         i = (GFC_UINTEGER_2) tmp;
 201       }
 202       break;
 203     case 4:
 204       {
 205         GFC_INTEGER_4 tmp;
 206         memcpy ((void *) &tmp, p, len);
 207         i = (GFC_UINTEGER_4) tmp;
 208       }
 209       break;
 210     case 8:
 211       {
 212         GFC_INTEGER_8 tmp;
 213         memcpy ((void *) &tmp, p, len);
 214         i = (GFC_UINTEGER_8) tmp;
 215       }
 216       break;
 217 #ifdef HAVE_GFC_INTEGER_16
 218     case 16:
 219       {
 220         GFC_INTEGER_16 tmp;
 221         memcpy ((void *) &tmp, p, len);
 222         i = (GFC_UINTEGER_16) tmp;
 223       }
 224       break;
 225 #endif
 226     default:
 227       internal_error (NULL, "bad integer kind");
 228     }
 229
 230   return i;
 231 }
 232
 233
 234 void
 235 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 236 {
 237   char *p;
 238   GFC_INTEGER_LARGEST n;
 239
 240   p = write_block (dtp, f->u.w);
 241   if (p == NULL)
 242     return;
 243
 244   memset (p, ' ', f->u.w - 1);
 245   n = extract_int (source, len);
 246   p[f->u.w - 1] = (n) ? 'T' : 'F';
 247 }
 248
 249
 250 static void
 251 write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
 252            const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
 253 {
 254   GFC_UINTEGER_LARGEST n = 0;
 255   int w, m, digits, nzero, nblank;
 256   char *p;
 257   const char *q;
 258   char itoa_buf[GFC_BTOA_BUF_SIZE];
 259
 260   w = f->u.integer.w;
 261   m = f->u.integer.m;
 262
 263   n = extract_uint (source, len);
 264
 265   /* Special case:  */
 266
 267   if (m == 0 && n == 0)
 268     {
 269       if (w == 0)
 270         w = 1;
 271
 272       p = write_block (dtp, w);
 273       if (p == NULL)
 274         return;
 275
 276       memset (p, ' ', w);
 277       goto done;
 278     }
 279
 280   q = conv (n, itoa_buf, sizeof (itoa_buf));
 281   digits = strlen (q);
 282
 283   /* Select a width if none was specified.  The idea here is to always
 284      print something.  */
 285
 286   if (w == 0)
 287     w = ((digits < m) ? m : digits);
 288
 289   p = write_block (dtp, w);
 290   if (p == NULL)
 291     return;
 292
 293   nzero = 0;
 294   if (digits < m)
 295     nzero = m - digits;
 296
 297   /* See if things will work.  */
 298
 299   nblank = w - (nzero + digits);
 300
 301   if (nblank < 0)
 302     {
 303       star_fill (p, w);
 304       goto done;
 305     }
 306
 307
 308   if (!dtp->u.p.no_leading_blank)
 309     {
 310       memset (p, ' ', nblank);
 311       p += nblank;
 312       memset (p, '0', nzero);
 313       p += nzero;
 314       memcpy (p, q, digits);
 315     }
 316   else
 317     {
 318       memset (p, '0', nzero);
 319       p += nzero;
 320       memcpy (p, q, digits);
 321       p += digits;
 322       memset (p, ' ', nblank);
 323       dtp->u.p.no_leading_blank = 0;
 324     }
 325
 326  done:
 327   return;
 328 }
 329
 330 static void
 331 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
 332                int len,
 333                const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
 334 {
 335   GFC_INTEGER_LARGEST n = 0;
 336   int w, m, digits, nsign, nzero, nblank;
 337   char *p;
 338   const char *q;
 339   sign_t sign;
 340   char itoa_buf[GFC_BTOA_BUF_SIZE];
 341
 342   w = f->u.integer.w;
 343   m = f->u.integer.m;
 344
 345   n = extract_int (source, len);
 346
 347   /* Special case:  */
 348
 349   if (m == 0 && n == 0)
 350     {
 351       if (w == 0)
 352         w = 1;
 353
 354       p = write_block (dtp, w);
 355       if (p == NULL)
 356         return;
 357
 358       memset (p, ' ', w);
 359       goto done;
 360     }
 361
 362   sign = calculate_sign (dtp, n < 0);
 363   if (n < 0)
 364     n = -n;
 365
 366   nsign = sign == S_NONE ? 0 : 1;
 367   q = conv (n, itoa_buf, sizeof (itoa_buf));
 368
 369   digits = strlen (q);
 370
 371   /* Select a width if none was specified.  The idea here is to always
 372      print something.  */
 373
 374   if (w == 0)
 375     w = ((digits < m) ? m : digits) + nsign;
 376
 377   p = write_block (dtp, w);
 378   if (p == NULL)
 379     return;
 380
 381   nzero = 0;
 382   if (digits < m)
 383     nzero = m - digits;
 384
 385   /* See if things will work.  */
 386
 387   nblank = w - (nsign + nzero + digits);
 388
 389   if (nblank < 0)
 390     {
 391       star_fill (p, w);
 392       goto done;
 393     }
 394
 395   memset (p, ' ', nblank);
 396   p += nblank;
 397
 398   switch (sign)
 399     {
 400     case S_PLUS:
 401       *p++ = '+';
 402       break;
 403     case S_MINUS:
 404       *p++ = '-';
 405       break;
 406     case S_NONE:
 407       break;
 408     }
 409
 410   memset (p, '0', nzero);
 411   p += nzero;
 412
 413   memcpy (p, q, digits);
 414
 415  done:
 416   return;
 417 }
 418
 419
 420 /* Convert unsigned octal to ascii.  */
 421
 422 static const char *
 423 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 424 {
 425   char *p;
 426
 427   assert (len >= GFC_OTOA_BUF_SIZE);
 428
 429   if (n == 0)
 430     return "0";
 431
 432   p = buffer + GFC_OTOA_BUF_SIZE - 1;
 433   *p = '\0';
 434
 435   while (n != 0)
 436     {
 437       *--p = '0' + (n & 7);
 438       n >>= 3;
 439     }
 440
 441   return p;
 442 }
 443
 444
 445 /* Convert unsigned binary to ascii.  */
 446
 447 static const char *
 448 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 449 {
 450   char *p;
 451
 452   assert (len >= GFC_BTOA_BUF_SIZE);
 453
 454   if (n == 0)
 455     return "0";
 456
 457   p = buffer + GFC_BTOA_BUF_SIZE - 1;
 458   *p = '\0';
 459
 460   while (n != 0)
 461     {
 462       *--p = '0' + (n & 1);
 463       n >>= 1;
 464     }
 465
 466   return p;
 467 }
 468
 469
 470 void
 471 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 472 {
 473   write_decimal (dtp, f, p, len, (void *) gfc_itoa);
 474 }
 475
 476
 477 void
 478 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 479 {
 480   write_int (dtp, f, p, len, btoa);
 481 }
 482
 483
 484 void
 485 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 486 {
 487   write_int (dtp, f, p, len, otoa);
 488 }
 489
 490 void
 491 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 492 {
 493   write_int (dtp, f, p, len, xtoa);
 494 }
 495
 496
 497 void
 498 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 499 {
 500   write_float (dtp, f, p, len);
 501 }
 502
 503
 504 void
 505 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 506 {
 507   write_float (dtp, f, p, len);
 508 }
 509
 510
 511 void
 512 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 513 {
 514   write_float (dtp, f, p, len);
 515 }
 516
 517
 518 void
 519 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 520 {
 521   write_float (dtp, f, p, len);
 522 }
 523
 524
 525 void
 526 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 527 {
 528   write_float (dtp, f, p, len);
 529 }
 530
 531
 532 /* Take care of the X/TR descriptor.  */
 533
 534 void
 535 write_x (st_parameter_dt *dtp, int len, int nspaces)
 536 {
 537   char *p;
 538
 539   p = write_block (dtp, len);
 540   if (p == NULL)
 541     return;
 542
 543   if (nspaces > 0)
 544     memset (&p[len - nspaces], ' ', nspaces);
 545 }
 546
 547
 548 /* List-directed writing.  */
 549
 550
 551 /* Write a single character to the output.  Returns nonzero if
 552    something goes wrong.  */
 553
 554 static int
 555 write_char (st_parameter_dt *dtp, char c)
 556 {
 557   char *p;
 558
 559   p = write_block (dtp, 1);
 560   if (p == NULL)
 561     return 1;
 562
 563   *p = c;
 564
 565   return 0;
 566 }
 567
 568
 569 /* Write a list-directed logical value.  */
 570
 571 static void
 572 write_logical (st_parameter_dt *dtp, const char *source, int length)
 573 {
 574   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
 575 }
 576
 577
 578 /* Write a list-directed integer value.  */
 579
 580 static void
 581 write_integer (st_parameter_dt *dtp, const char *source, int length)
 582 {
 583   char *p;
 584   const char *q;
 585   int digits;
 586   int width;
 587   char itoa_buf[GFC_ITOA_BUF_SIZE];
 588
 589   q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
 590
 591   switch (length)
 592     {
 593     case 1:
 594       width = 4;
 595       break;
 596
 597     case 2:
 598       width = 6;
 599       break;
 600
 601     case 4:
 602       width = 11;
 603       break;
 604
 605     case 8:
 606       width = 20;
 607       break;
 608
 609     default:
 610       width = 0;
 611       break;
 612     }
 613
 614   digits = strlen (q);
 615
 616   if (width < digits)
 617     width = digits;
 618   p = write_block (dtp, width);
 619   if (p == NULL)
 620     return;
 621   if (dtp->u.p.no_leading_blank)
 622     {
 623       memcpy (p, q, digits);
 624       memset (p + digits, ' ', width - digits);
 625     }
 626   else
 627     {
 628       memset (p, ' ', width - digits);
 629       memcpy (p + width - digits, q, digits);
 630     }
 631 }
 632
 633
 634 /* Write a list-directed string.  We have to worry about delimiting
 635    the strings if the file has been opened in that mode.  */
 636
 637 static void
 638 write_character (st_parameter_dt *dtp, const char *source, int length)
 639 {
 640   int i, extra;
 641   char *p, d;
 642
 643   switch (dtp->u.p.delim_status)
 644     {
 645     case DELIM_APOSTROPHE:
 646       d = '\'';
 647       break;
 648     case DELIM_QUOTE:
 649       d = '"';
 650       break;
 651     default:
 652       d = ' ';
 653       break;
 654     }
 655
 656   if (d == ' ')
 657     extra = 0;
 658   else
 659     {
 660       extra = 2;
 661
 662       for (i = 0; i < length; i++)
 663         if (source[i] == d)
 664           extra++;
 665     }
 666
 667   p = write_block (dtp, length + extra);
 668   if (p == NULL)
 669     return;
 670
 671   if (d == ' ')
 672     memcpy (p, source, length);
 673   else
 674     {
 675       *p++ = d;
 676
 677       for (i = 0; i < length; i++)
 678         {
 679           *p++ = source[i];
 680           if (source[i] == d)
 681             *p++ = d;
 682         }
 683
 684       *p = d;
 685     }
 686 }
 687
 688
 689 /* Output a real number with default format.
 690    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
 691    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
 692
 693 static void
 694 write_real (st_parameter_dt *dtp, const char *source, int length)
 695 {
 696   fnode f ;
 697   int org_scale = dtp->u.p.scale_factor;
 698   f.format = FMT_G;
 699   dtp->u.p.scale_factor = 1;
 700   switch (length)
 701     {
 702     case 4:
 703       f.u.real.w = 15;
 704       f.u.real.d = 8;
 705       f.u.real.e = 2;
 706       break;
 707     case 8:
 708       f.u.real.w = 25;
 709       f.u.real.d = 17;
 710       f.u.real.e = 3;
 711       break;
 712     case 10:
 713       f.u.real.w = 29;
 714       f.u.real.d = 20;
 715       f.u.real.e = 4;
 716       break;
 717     case 16:
 718       f.u.real.w = 44;
 719       f.u.real.d = 35;
 720       f.u.real.e = 4;
 721       break;
 722     default:
 723       internal_error (&dtp->common, "bad real kind");
 724       break;
 725     }
 726   write_float (dtp, &f, source , length);
 727   dtp->u.p.scale_factor = org_scale;
 728 }
 729
 730
 731 static void
 732 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
 733 {
 734   char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
 735
 736   if (write_char (dtp, '('))
 737     return;
 738   write_real (dtp, source, kind);
 739
 740   if (write_char (dtp, semi_comma))
 741     return;
 742   write_real (dtp, source + size / 2, kind);
 743
 744   write_char (dtp, ')');
 745 }
 746
 747
 748 /* Write the separator between items.  */
 749
 750 static void
 751 write_separator (st_parameter_dt *dtp)
 752 {
 753   char *p;
 754
 755   p = write_block (dtp, options.separator_len);
 756   if (p == NULL)
 757     return;
 758
 759   memcpy (p, options.separator, options.separator_len);
 760 }
 761
 762
 763 /* Write an item with list formatting.
 764    TODO: handle skipping to the next record correctly, particularly
 765    with strings.  */
 766
 767 static void
 768 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 769                              size_t size)
 770 {
 771   if (dtp->u.p.current_unit == NULL)
 772     return;
 773
 774   if (dtp->u.p.first_item)
 775     {
 776       dtp->u.p.first_item = 0;
 777       write_char (dtp, ' ');
 778     }
 779   else
 780     {
 781       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
 782           dtp->u.p.delim_status != DELIM_NONE)
 783         write_separator (dtp);
 784     }
 785
 786   switch (type)
 787     {
 788     case BT_INTEGER:
 789       write_integer (dtp, p, kind);
 790       break;
 791     case BT_LOGICAL:
 792       write_logical (dtp, p, kind);
 793       break;
 794     case BT_CHARACTER:
 795       write_character (dtp, p, kind);
 796       break;
 797     case BT_REAL:
 798       write_real (dtp, p, kind);
 799       break;
 800     case BT_COMPLEX:
 801       write_complex (dtp, p, kind, size);
 802       break;
 803     default:
 804       internal_error (&dtp->common, "list_formatted_write(): Bad type");
 805     }
 806
 807   dtp->u.p.char_flag = (type == BT_CHARACTER);
 808 }
 809
 810
 811 void
 812 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
 813                       size_t size, size_t nelems)
 814 {
 815   size_t elem;
 816   char *tmp;
 817
 818   tmp = (char *) p;
 819
 820   /* Big loop over all the elements.  */
 821   for (elem = 0; elem < nelems; elem++)
 822     {
 823       dtp->u.p.item_count++;
 824       list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
 825     }
 826 }
 827
 828 /*                      NAMELIST OUTPUT
 829
 830    nml_write_obj writes a namelist object to the output stream.  It is called
 831    recursively for derived type components:
 832         obj    = is the namelist_info for the current object.
 833         offset = the offset relative to the address held by the object for
 834                  derived type arrays.
 835         base   = is the namelist_info of the derived type, when obj is a
 836                  component.
 837         base_name = the full name for a derived type, including qualifiers
 838                     if any.
 839    The returned value is a pointer to the object beyond the last one
 840    accessed, including nested derived types.  Notice that the namelist is
 841    a linear linked list of objects, including derived types and their
 842    components.  A tree, of sorts, is implied by the compound names of
 843    the derived type components and this is how this function recurses through
 844    the list.  */
 845
 846 /* A generous estimate of the number of characters needed to print
 847    repeat counts and indices, including commas, asterices and brackets.  */
 848
 849 #define NML_DIGITS 20
 850
 851 static namelist_info *
 852 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 853                namelist_info * base, char * base_name)
 854 {
 855   int rep_ctr;
 856   int num;
 857   int nml_carry;
 858   index_type len;
 859   index_type obj_size;
 860   index_type nelem;
 861   index_type dim_i;
 862   index_type clen;
 863   index_type elem_ctr;
 864   index_type obj_name_len;
 865   void * p ;
 866   char cup;
 867   char * obj_name;
 868   char * ext_name;
 869   char rep_buff[NML_DIGITS];
 870   namelist_info * cmp;
 871   namelist_info * retval = obj->next;
 872   size_t base_name_len;
 873   size_t base_var_name_len;
 874   size_t tot_len;
 875   unit_delim tmp_delim;
 876
 877   /* Set the character to be used to separate values
 878      to a comma or semi-colon.  */
 879
 880   char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
 881
 882   /* Write namelist variable names in upper case. If a derived type,
 883      nothing is output.  If a component, base and base_name are set.  */
 884
 885   if (obj->type != GFC_DTYPE_DERIVED)
 886     {
 887 #ifdef HAVE_CRLF
 888       write_character (dtp, "\r\n ", 3);
 889 #else
 890       write_character (dtp, "\n ", 2);
 891 #endif
 892       len = 0;
 893       if (base)
 894         {
 895           len =strlen (base->var_name);
 896           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
 897             {
 898               cup = toupper (base_name[dim_i]);
 899               write_character (dtp, &cup, 1);
 900             }
 901         }
 902       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
 903         {
 904           cup = toupper (obj->var_name[dim_i]);
 905           write_character (dtp, &cup, 1);
 906         }
 907       write_character (dtp, "=", 1);
 908     }
 909
 910   /* Counts the number of data output on a line, including names.  */
 911
 912   num = 1;
 913
 914   len = obj->len;
 915
 916   switch (obj->type)
 917     {
 918
 919     case GFC_DTYPE_REAL:
 920       obj_size = size_from_real_kind (len);
 921       break;
 922
 923     case GFC_DTYPE_COMPLEX:
 924       obj_size = size_from_complex_kind (len);
 925       break;
 926
 927     case GFC_DTYPE_CHARACTER:
 928       obj_size = obj->string_length;
 929       break;
 930
 931     default:
 932       obj_size = len;
 933     }
 934
 935   if (obj->var_rank)
 936     obj_size = obj->size;
 937
 938   /* Set the index vector and count the number of elements.  */
 939
 940   nelem = 1;
 941   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
 942     {
 943       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
 944       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
 945     }
 946
 947   /* Main loop to output the data held in the object.  */
 948
 949   rep_ctr = 1;
 950   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
 951     {
 952
 953       /* Build the pointer to the data value.  The offset is passed by
 954          recursive calls to this function for arrays of derived types.
 955          Is NULL otherwise.  */
 956
 957       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
 958       p += offset;
 959
 960       /* Check for repeat counts of intrinsic types.  */
 961
 962       if ((elem_ctr < (nelem - 1)) &&
 963           (obj->type != GFC_DTYPE_DERIVED) &&
 964           !memcmp (p, (void*)(p + obj_size ), obj_size ))
 965         {
 966           rep_ctr++;
 967         }
 968
 969       /* Execute a repeated output.  Note the flag no_leading_blank that
 970          is used in the functions used to output the intrinsic types.  */
 971
 972       else
 973         {
 974           if (rep_ctr > 1)
 975             {
 976               sprintf(rep_buff, " %d*", rep_ctr);
 977               write_character (dtp, rep_buff, strlen (rep_buff));
 978               dtp->u.p.no_leading_blank = 1;
 979             }
 980           num++;
 981
 982           /* Output the data, if an intrinsic type, or recurse into this
 983              routine to treat derived types.  */
 984
 985           switch (obj->type)
 986             {
 987
 988             case GFC_DTYPE_INTEGER:
 989               write_integer (dtp, p, len);
 990               break;
 991
 992             case GFC_DTYPE_LOGICAL:
 993               write_logical (dtp, p, len);
 994               break;
 995
 996             case GFC_DTYPE_CHARACTER:
 997               tmp_delim = dtp->u.p.delim_status;
 998               if (dtp->u.p.nml_delim == '"')
 999                 dtp->u.p.delim_status = DELIM_QUOTE;
1000               if (dtp->u.p.nml_delim == '\'')
1001                 dtp->u.p.delim_status = DELIM_APOSTROPHE;
1002               write_character (dtp, p, obj->string_length);
1003               dtp->u.p.delim_status = tmp_delim;
1004               break;
1005
1006             case GFC_DTYPE_REAL:
1007               write_real (dtp, p, len);
1008               break;
1009
1010             case GFC_DTYPE_COMPLEX:
1011               dtp->u.p.no_leading_blank = 0;
1012               num++;
1013               write_complex (dtp, p, len, obj_size);
1014               break;
1015
1016             case GFC_DTYPE_DERIVED:
1017
1018               /* To treat a derived type, we need to build two strings:
1019                  ext_name = the name, including qualifiers that prepends
1020                             component names in the output - passed to
1021                             nml_write_obj.
1022                  obj_name = the derived type name with no qualifiers but %
1023                             appended.  This is used to identify the
1024                             components.  */
1025
1026               /* First ext_name => get length of all possible components  */
1027
1028               base_name_len = base_name ? strlen (base_name) : 0;
1029               base_var_name_len = base ? strlen (base->var_name) : 0;
1030               ext_name = (char*)get_mem ( base_name_len
1031                                         + base_var_name_len
1032                                         + strlen (obj->var_name)
1033                                         + obj->var_rank * NML_DIGITS
1034                                         + 1);
1035
1036               memcpy (ext_name, base_name, base_name_len);
1037               clen = strlen (obj->var_name + base_var_name_len);
1038               memcpy (ext_name + base_name_len,
1039                       obj->var_name + base_var_name_len, clen);
1040
1041               /* Append the qualifier.  */
1042
1043               tot_len = base_name_len + clen;
1044               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1045                 {
1046                   if (!dim_i)
1047                     {
1048                       ext_name[tot_len] = '(';
1049                       tot_len++;
1050                     }
1051                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1052                   tot_len += strlen (ext_name + tot_len);
1053                   ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1054                   tot_len++;
1055                 }
1056
1057               ext_name[tot_len] = '\0';
1058
1059               /* Now obj_name.  */
1060
1061               obj_name_len = strlen (obj->var_name) + 1;
1062               obj_name = get_mem (obj_name_len+1);
1063               memcpy (obj_name, obj->var_name, obj_name_len-1);
1064               memcpy (obj_name + obj_name_len-1, "%", 2);
1065
1066               /* Now loop over the components. Update the component pointer
1067                  with the return value from nml_write_obj => this loop jumps
1068                  past nested derived types.  */
1069
1070               for (cmp = obj->next;
1071                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1072                    cmp = retval)
1073                 {
1074                   retval = nml_write_obj (dtp, cmp,
1075                                           (index_type)(p - obj->mem_pos),
1076                                           obj, ext_name);
1077                 }
1078
1079               free_mem (obj_name);
1080               free_mem (ext_name);
1081               goto obj_loop;
1082
1083             default:
1084               internal_error (&dtp->common, "Bad type for namelist write");
1085             }
1086
1087           /* Reset the leading blank suppression, write a comma (or semi-colon)
1088              and, if 5 values have been output, write a newline and advance
1089              to column 2. Reset the repeat counter.  */
1090
1091           dtp->u.p.no_leading_blank = 0;
1092           write_character (dtp, &semi_comma, 1);
1093           if (num > 5)
1094             {
1095               num = 0;
1096 #ifdef HAVE_CRLF
1097               write_character (dtp, "\r\n ", 3);
1098 #else
1099               write_character (dtp, "\n ", 2);
1100 #endif
1101             }
1102           rep_ctr = 1;
1103         }
1104
1105     /* Cycle through and increment the index vector.  */
1106
1107 obj_loop:
1108
1109     nml_carry = 1;
1110     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1111       {
1112         obj->ls[dim_i].idx += nml_carry ;
1113         nml_carry = 0;
1114         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1115           {
1116             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1117             nml_carry = 1;
1118           }
1119        }
1120     }
1121
1122   /* Return a pointer beyond the furthest object accessed.  */
1123
1124   return retval;
1125 }
1126
1127 /* This is the entry function for namelist writes.  It outputs the name
1128    of the namelist and iterates through the namelist by calls to
1129    nml_write_obj.  The call below has dummys in the arguments used in
1130    the treatment of derived types.  */
1131
1132 void
1133 namelist_write (st_parameter_dt *dtp)
1134 {
1135   namelist_info * t1, *t2, *dummy = NULL;
1136   index_type i;
1137   index_type dummy_offset = 0;
1138   char c;
1139   char * dummy_name = NULL;
1140   unit_delim tmp_delim;
1141
1142   /* Set the delimiter for namelist output.  */
1143
1144   tmp_delim = dtp->u.p.delim_status;
1145   switch (tmp_delim)
1146     {
1147     case (DELIM_QUOTE):
1148       dtp->u.p.nml_delim = '"';
1149       break;
1150
1151     case (DELIM_APOSTROPHE):
1152       dtp->u.p.nml_delim = '\'';
1153       break;
1154
1155     default:
1156       dtp->u.p.nml_delim = '\0';
1157       break;
1158     }
1159
1160   /* Temporarily disable namelist delimters.  */
1161   dtp->u.p.delim_status = DELIM_NONE;
1162
1163   write_character (dtp, "&", 1);
1164
1165   /* Write namelist name in upper case - f95 std.  */
1166   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1167     {
1168       c = toupper (dtp->namelist_name[i]);
1169       write_character (dtp, &c ,1);
1170     }
1171
1172   if (dtp->u.p.ionml != NULL)
1173     {
1174       t1 = dtp->u.p.ionml;
1175       while (t1 != NULL)
1176         {
1177           t2 = t1;
1178           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1179         }
1180     }
1181
1182 #ifdef HAVE_CRLF
1183   write_character (dtp, "  /\r\n", 5);
1184 #else
1185   write_character (dtp, "  /\n", 4);
1186 #endif
1187
1188   /* Restore the original delimiter.  */
1189   dtp->u.p.delim_status = tmp_delim;
1190 }
1191
1192 #undef NML_DIGITS