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 = 14;
 702       f.u.real.d = 7;
 703       f.u.real.e = 2;
 704       break;
 705     case 8:
 706       f.u.real.w = 23;
 707       f.u.real.d = 15;
 708       f.u.real.e = 3;
 709       break;
 710     case 10:
 711       f.u.real.w = 28;
 712       f.u.real.d = 19;
 713       f.u.real.e = 4;
 714       break;
 715     case 16:
 716       f.u.real.w = 43;
 717       f.u.real.d = 34;
 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
 872   /* Write namelist variable names in upper case. If a derived type,
 873      nothing is output.  If a component, base and base_name are set.  */
 874
 875   if (obj->type != GFC_DTYPE_DERIVED)
 876     {
 877 #ifdef HAVE_CRLF
 878       write_character (dtp, "\r\n ", 3);
 879 #else
 880       write_character (dtp, "\n ", 2);
 881 #endif
 882       len = 0;
 883       if (base)
 884         {
 885           len =strlen (base->var_name);
 886           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
 887             {
 888               cup = toupper (base_name[dim_i]);
 889               write_character (dtp, &cup, 1);
 890             }
 891         }
 892       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
 893         {
 894           cup = toupper (obj->var_name[dim_i]);
 895           write_character (dtp, &cup, 1);
 896         }
 897       write_character (dtp, "=", 1);
 898     }
 899
 900   /* Counts the number of data output on a line, including names.  */
 901
 902   num = 1;
 903
 904   len = obj->len;
 905
 906   switch (obj->type)
 907     {
 908
 909     case GFC_DTYPE_REAL:
 910       obj_size = size_from_real_kind (len);
 911       break;
 912
 913     case GFC_DTYPE_COMPLEX:
 914       obj_size = size_from_complex_kind (len);
 915       break;
 916
 917     case GFC_DTYPE_CHARACTER:
 918       obj_size = obj->string_length;
 919       break;
 920
 921     default:
 922       obj_size = len;
 923     }
 924
 925   if (obj->var_rank)
 926     obj_size = obj->size;
 927
 928   /* Set the index vector and count the number of elements.  */
 929
 930   nelem = 1;
 931   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
 932     {
 933       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
 934       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
 935     }
 936
 937   /* Main loop to output the data held in the object.  */
 938
 939   rep_ctr = 1;
 940   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
 941     {
 942
 943       /* Build the pointer to the data value.  The offset is passed by
 944          recursive calls to this function for arrays of derived types.
 945          Is NULL otherwise.  */
 946
 947       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
 948       p += offset;
 949
 950       /* Check for repeat counts of intrinsic types.  */
 951
 952       if ((elem_ctr < (nelem - 1)) &&
 953           (obj->type != GFC_DTYPE_DERIVED) &&
 954           !memcmp (p, (void*)(p + obj_size ), obj_size ))
 955         {
 956           rep_ctr++;
 957         }
 958
 959       /* Execute a repeated output.  Note the flag no_leading_blank that
 960          is used in the functions used to output the intrinsic types.  */
 961
 962       else
 963         {
 964           if (rep_ctr > 1)
 965             {
 966               sprintf(rep_buff, " %d*", rep_ctr);
 967               write_character (dtp, rep_buff, strlen (rep_buff));
 968               dtp->u.p.no_leading_blank = 1;
 969             }
 970           num++;
 971
 972           /* Output the data, if an intrinsic type, or recurse into this
 973              routine to treat derived types.  */
 974
 975           switch (obj->type)
 976             {
 977
 978             case GFC_DTYPE_INTEGER:
 979               write_integer (dtp, p, len);
 980               break;
 981
 982             case GFC_DTYPE_LOGICAL:
 983               write_logical (dtp, p, len);
 984               break;
 985
 986             case GFC_DTYPE_CHARACTER:
 987               if (dtp->u.p.nml_delim)
 988                 write_character (dtp, &dtp->u.p.nml_delim, 1);
 989               write_character (dtp, p, obj->string_length);
 990               if (dtp->u.p.nml_delim)
 991                 write_character (dtp, &dtp->u.p.nml_delim, 1);
 992               break;
 993
 994             case GFC_DTYPE_REAL:
 995               write_real (dtp, p, len);
 996               break;
 997
 998             case GFC_DTYPE_COMPLEX:
 999               dtp->u.p.no_leading_blank = 0;
1000               num++;
1001               write_complex (dtp, p, len, obj_size);
1002               break;
1003
1004             case GFC_DTYPE_DERIVED:
1005
1006               /* To treat a derived type, we need to build two strings:
1007                  ext_name = the name, including qualifiers that prepends
1008                             component names in the output - passed to
1009                             nml_write_obj.
1010                  obj_name = the derived type name with no qualifiers but %
1011                             appended.  This is used to identify the
1012                             components.  */
1013
1014               /* First ext_name => get length of all possible components  */
1015
1016               base_name_len = base_name ? strlen (base_name) : 0;
1017               base_var_name_len = base ? strlen (base->var_name) : 0;
1018               ext_name = (char*)get_mem ( base_name_len
1019                                         + base_var_name_len
1020                                         + strlen (obj->var_name)
1021                                         + obj->var_rank * NML_DIGITS
1022                                         + 1);
1023
1024               memcpy (ext_name, base_name, base_name_len);
1025               clen = strlen (obj->var_name + base_var_name_len);
1026               memcpy (ext_name + base_name_len,
1027                       obj->var_name + base_var_name_len, clen);
1028
1029               /* Append the qualifier.  */
1030
1031               tot_len = base_name_len + clen;
1032               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1033                 {
1034                   if (!dim_i)
1035                     {
1036                       ext_name[tot_len] = '(';
1037                       tot_len++;
1038                     }
1039                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1040                   tot_len += strlen (ext_name + tot_len);
1041                   ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1042                   tot_len++;
1043                 }
1044
1045               ext_name[tot_len] = '\0';
1046
1047               /* Now obj_name.  */
1048
1049               obj_name_len = strlen (obj->var_name) + 1;
1050               obj_name = get_mem (obj_name_len+1);
1051               memcpy (obj_name, obj->var_name, obj_name_len-1);
1052               memcpy (obj_name + obj_name_len-1, "%", 2);
1053
1054               /* Now loop over the components. Update the component pointer
1055                  with the return value from nml_write_obj => this loop jumps
1056                  past nested derived types.  */
1057
1058               for (cmp = obj->next;
1059                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1060                    cmp = retval)
1061                 {
1062                   retval = nml_write_obj (dtp, cmp,
1063                                           (index_type)(p - obj->mem_pos),
1064                                           obj, ext_name);
1065                 }
1066
1067               free_mem (obj_name);
1068               free_mem (ext_name);
1069               goto obj_loop;
1070
1071             default:
1072               internal_error (&dtp->common, "Bad type for namelist write");
1073             }
1074
1075           /* Reset the leading blank suppression, write a comma and, if 5
1076              values have been output, write a newline and advance to column
1077              2. Reset the repeat counter.  */
1078
1079           dtp->u.p.no_leading_blank = 0;
1080           write_character (dtp, ",", 1);
1081           if (num > 5)
1082             {
1083               num = 0;
1084 #ifdef HAVE_CRLF
1085               write_character (dtp, "\r\n ", 3);
1086 #else
1087               write_character (dtp, "\n ", 2);
1088 #endif
1089             }
1090           rep_ctr = 1;
1091         }
1092
1093     /* Cycle through and increment the index vector.  */
1094
1095 obj_loop:
1096
1097     nml_carry = 1;
1098     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1099       {
1100         obj->ls[dim_i].idx += nml_carry ;
1101         nml_carry = 0;
1102         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1103           {
1104             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1105             nml_carry = 1;
1106           }
1107        }
1108     }
1109
1110   /* Return a pointer beyond the furthest object accessed.  */
1111
1112   return retval;
1113 }
1114
1115 /* This is the entry function for namelist writes.  It outputs the name
1116    of the namelist and iterates through the namelist by calls to
1117    nml_write_obj.  The call below has dummys in the arguments used in
1118    the treatment of derived types.  */
1119
1120 void
1121 namelist_write (st_parameter_dt *dtp)
1122 {
1123   namelist_info * t1, *t2, *dummy = NULL;
1124   index_type i;
1125   index_type dummy_offset = 0;
1126   char c;
1127   char * dummy_name = NULL;
1128   unit_delim tmp_delim;
1129
1130   /* Set the delimiter for namelist output.  */
1131
1132   tmp_delim = dtp->u.p.current_unit->flags.delim;
1133   dtp->u.p.current_unit->flags.delim = DELIM_NONE;
1134   switch (tmp_delim)
1135     {
1136     case (DELIM_QUOTE):
1137       dtp->u.p.nml_delim = '"';
1138       break;
1139
1140     case (DELIM_APOSTROPHE):
1141       dtp->u.p.nml_delim = '\'';
1142       break;
1143
1144     default:
1145       dtp->u.p.nml_delim = '\0';
1146       break;
1147     }
1148
1149   write_character (dtp, "&", 1);
1150
1151   /* Write namelist name in upper case - f95 std.  */
1152
1153   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1154     {
1155       c = toupper (dtp->namelist_name[i]);
1156       write_character (dtp, &c ,1);
1157     }
1158
1159   if (dtp->u.p.ionml != NULL)
1160     {
1161       t1 = dtp->u.p.ionml;
1162       while (t1 != NULL)
1163         {
1164           t2 = t1;
1165           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1166         }
1167     }
1168 #ifdef HAVE_CRLF
1169   write_character (dtp, "  /\r\n", 5);
1170 #else
1171   write_character (dtp, "  /\n", 4);
1172 #endif
1173
1174   /* Recover the original delimiter.  */
1175
1176   dtp->u.p.current_unit->flags.delim = tmp_delim;
1177 }
1178
1179 #undef NML_DIGITS