libgfortran/io/write.c

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