libgfortran/io/write.c

   1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with Libgfortran; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 #include "config.h"
  22 #include <string.h>
  23 #include <float.h>
  24 #include "libgfortran.h"
  25 #include "io.h"
  26 #include <stdio.h>
  27
  28
  29 #define star_fill(p, n) memset(p, '*', n)
  30
  31
  32 typedef enum
  33 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
  34 sign_t;
  35
  36
  37 void
  38 write_a (fnode * f, const char *source, int len)
  39 {
  40   int wlen;
  41   char *p;
  42
  43   wlen = f->u.string.length < 0 ? len : f->u.string.length;
  44
  45   p = write_block (wlen);
  46   if (p == NULL)
  47     return;
  48
  49   if (wlen < len)
  50     memcpy (p, source, wlen);
  51   else
  52     {
  53       memset (p, ' ', wlen - len);
  54       memcpy (p + wlen - len, source, len);
  55     }
  56 }
  57
  58 static int64_t
  59 extract_int (const void *p, int len)
  60 {
  61   int64_t i = 0;
  62
  63   if (p == NULL)
  64     return i;
  65
  66   switch (len)
  67     {
  68     case 1:
  69       i = *((const int8_t *) p);
  70       break;
  71     case 2:
  72       i = *((const int16_t *) p);
  73       break;
  74     case 4:
  75       i = *((const int32_t *) p);
  76       break;
  77     case 8:
  78       i = *((const int64_t *) p);
  79       break;
  80     default:
  81       internal_error ("bad integer kind");
  82     }
  83
  84   return i;
  85 }
  86
  87 static double
  88 extract_real (const void *p, int len)
  89 {
  90   double i = 0.0;
  91   switch (len)
  92     {
  93     case 4:
  94       i = *((const float *) p);
  95       break;
  96     case 8:
  97       i = *((const double *) p);
  98       break;
  99     default:
 100       internal_error ("bad real kind");
 101     }
 102   return i;
 103
 104 }
 105
 106
 107 /* Given a flag that indicate if a value is negative or not, return a
 108    sign_t that gives the sign that we need to produce.  */
 109
 110 static sign_t
 111 calculate_sign (int negative_flag)
 112 {
 113   sign_t s = SIGN_NONE;
 114
 115   if (negative_flag)
 116     s = SIGN_MINUS;
 117   else
 118     switch (g.sign_status)
 119       {
 120       case SIGN_SP:
 121         s = SIGN_PLUS;
 122         break;
 123       case SIGN_SS:
 124         s = SIGN_NONE;
 125         break;
 126       case SIGN_S:
 127         s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
 128         break;
 129       }
 130
 131   return s;
 132 }
 133
 134
 135 /* Returns the value of 10**d.  */
 136
 137 static double
 138 calculate_exp (int d)
 139 {
 140   int i;
 141   double r = 1.0;
 142
 143   for (i = 0; i< (d >= 0 ? d : -d); i++)
 144     r *= 10;
 145
 146   r = (d >= 0) ? r : 1.0 / r;
 147
 148   return r;
 149 }
 150
 151
 152 /* Generate corresponding I/O format for FMT_G output.
 153    The rules to translate FMT_G to FMT_E or FNT_F from DEC fortran
 154    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
 155
 156    Data Magnitude                              Equivalent Conversion
 157    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
 158    m = 0                                       F(w-n).(d-1), n' '
 159    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
 160    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
 161    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
 162    ................                           ..........
 163    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
 164    m >= 10**d-0.5                              Ew.d[Ee]
 165
 166    notes: for Gw.d ,  n' ' means 4 blanks
 167           for Gw.dEe, n' ' means e+2 blanks  */
 168
 169 static fnode *
 170 calculate_G_format (fnode *f, double value, int len, int *num_blank)
 171 {
 172   int e = f->u.real.e;
 173   int d = f->u.real.d;
 174   int w = f->u.real.w;
 175   fnode *newf;
 176   double m, exp_d;
 177   int low, high, mid;
 178   int ubound, lbound;
 179
 180   newf = get_mem (sizeof (fnode));
 181
 182   /* Absolute value.  */
 183   m = (value > 0.0) ? value : -value;
 184
 185   /* In case of the two data magnitude ranges,
 186      generate E editing, Ew.d[Ee].  */
 187   exp_d = calculate_exp (d);
 188   if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
 189       || (m >= (double) exp_d - 0.5 ))
 190     {
 191       newf->format = FMT_E;
 192       newf->u.real.w = w;
 193       newf->u.real.d = d;
 194       newf->u.real.e = e;
 195       *num_blank = e + 2;
 196       return newf;
 197     }
 198
 199   /* Use binary search to find the data magnitude range.  */
 200   mid = 0;
 201   low = 0;
 202   high = d + 1;
 203   lbound = 0;
 204   ubound = d + 1;
 205
 206   while (low <= high)
 207     {
 208       double temp;
 209       mid = (low + high) / 2;
 210
 211       /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
 212       temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
 213
 214       if (m < temp)
 215         {
 216           ubound = mid;
 217           if (ubound == lbound + 1)
 218             break;
 219           high = mid - 1;
 220         }
 221       else if (m > temp)
 222         {
 223           lbound = mid;
 224           if (ubound == lbound + 1)
 225             {
 226               mid ++;
 227               break;
 228             }
 229           low = mid + 1;
 230         }
 231       else
 232         break;
 233     }
 234
 235   /* Generate the F editing. F(w-4).(-(mid-d-1)), 4' '.  */
 236   newf->format = FMT_F;
 237   newf->u.real.w = f->u.real.w - 4;
 238
 239   /* Special case.  */
 240   if (m == 0.0)
 241     newf->u.real.d = d - 1;
 242   else
 243     newf->u.real.d = - (mid - d - 1);
 244
 245   *num_blank = 4;
 246
 247   /* For F editing, the scale factor is ignored.  */
 248   g.scale_factor = 0;
 249   return newf;
 250 }
 251
 252
 253 /* Output a real number according to its format which is FMT_G free.  */
 254
 255 static void
 256 output_float (fnode *f, double value, int len)
 257 {
 258   int w, d, e, e_new;
 259   int digits;
 260   int nsign, nblank, nesign;
 261   int sca, neval, itmp;
 262   char *p;
 263   const char *q, *intstr, *base;
 264   double n;
 265   format_token ft;
 266   char exp_char = 'E';
 267   int with_exp = 1;
 268   int scale_flag = 1 ;
 269   double minv = 0.0, maxv = 0.0;
 270   sign_t sign = SIGN_NONE, esign = SIGN_NONE;
 271
 272   int intval = 0, intlen = 0;
 273   int j;
 274
 275   /* EXP value for this number.  */
 276   neval = 0;
 277
 278   /* Width of EXP and it's sign.  */
 279   nesign = 0;
 280
 281   ft = f->format;
 282   w = f->u.real.w;
 283   d = f->u.real.d + 1;
 284
 285   /* Width of the EXP.  */
 286   e = 0;
 287
 288   sca = g.scale_factor;
 289   n = value;
 290
 291   sign = calculate_sign (n < 0.0);
 292   if (n < 0)
 293     n = -n;
 294
 295   /* Width of the sign for the whole number.  */
 296   nsign = (sign == SIGN_NONE ? 0 : 1);
 297
 298   digits = 0;
 299   if (ft != FMT_F)
 300     {
 301       e = f->u.real.e;
 302     }
 303   if (ft == FMT_F || ft == FMT_E || ft == FMT_D)
 304     {
 305       if (ft == FMT_F)
 306         scale_flag = 0;
 307       if (ft == FMT_D)
 308         exp_char = 'D' ;
 309       minv = 0.1;
 310       maxv = 1.0;
 311
 312       /* Calculate the new val of the number with consideration
 313          of global scale value.  */
 314       while (sca >  0)
 315         {
 316           minv *= 10.0;
 317           maxv *= 10.0;
 318           n *= 10.0;
 319           sca -- ;
 320           neval --;
 321         }
 322
 323       /* Now calculate the new Exp value for this number.  */
 324       sca = g.scale_factor;
 325       while(sca >= 1)
 326         {
 327           sca /= 10;
 328           digits ++ ;
 329         }
 330     }
 331
 332    if (ft == FMT_EN )
 333      {
 334        minv = 1.0;
 335        maxv = 1000.0;
 336      }
 337    if (ft == FMT_ES)
 338      {
 339        minv = 1.0;
 340        maxv = 10.0;
 341      }
 342
 343    /* OK, let's scale the number to appropriate range.  */
 344    while (scale_flag && n > 0.0 && n < minv)
 345      {
 346        if (n < minv)
 347          {
 348            n = n * 10.0 ;
 349            neval --;
 350          }
 351      }
 352    while (scale_flag && n > 0.0 && n > maxv)
 353      {
 354        if (n > maxv)
 355          {
 356            n = n / 10.0 ;
 357            neval ++;
 358          }
 359      }
 360
 361   /* It is time to process the EXP part of the number.
 362      Value of 'nesign' is 0 unless following codes is executed.  */
 363   if (ft != FMT_F)
 364     {
 365      /* Sign of the EXP value.  */
 366      if (neval >= 0)
 367        esign = SIGN_PLUS;
 368      else
 369        {
 370          esign = SIGN_MINUS;
 371          neval = - neval ;
 372        }
 373
 374       /* Width of the EXP.  */
 375       e_new = 0;
 376       j = neval;
 377       while (j > 0)
 378         {
 379            j = j / 10;
 380            e_new ++ ;
 381         }
 382       if (e <= e_new)
 383          e = e_new;
 384
 385      /* Got the width of EXP.  */
 386      if (e < digits)
 387        e = digits ;
 388
 389      /* Minimum value of the width would be 2.  */
 390      if (e < 2)
 391        e = 2;
 392
 393      nesign =  1 ;  /* We must give a position for the 'exp_char'  */
 394      if (e > 0)
 395        nesign = e + nesign + (esign != SIGN_NONE ? 1 : 0);
 396    }
 397
 398
 399   intval = n;
 400   intstr = itoa (intval);
 401   intlen = strlen (intstr);
 402
 403   q = rtoa (n, len, d);
 404   digits = strlen (q);
 405
 406   /* Select a width if none was specified.  */
 407   if (w <= 0)
 408     w = digits + nsign;
 409
 410   p = write_block (w);
 411   if (p == NULL)
 412     return;
 413
 414   base = p;
 415
 416   nblank = w - (nsign + intlen + d + nesign);
 417   if (nblank == -1 && ft != FMT_F)
 418      {
 419        with_exp = 0;
 420        nesign -= 1;
 421        nblank = w - (nsign + intlen + d + nesign);
 422      }
 423   /* Don't let a leading '0' cause field overflow.  */
 424   if (nblank == -1 && ft == FMT_F && q[0] == '0')
 425      {
 426         q++;
 427         nblank = 0;
 428      }
 429
 430   if (nblank < 0)
 431     {
 432       star_fill (p, w);
 433       goto done;
 434     }
 435   memset (p, ' ', nblank);
 436   p += nblank;
 437
 438   switch (sign)
 439     {
 440     case SIGN_PLUS:
 441       *p++ = '+';
 442       break;
 443     case SIGN_MINUS:
 444       *p++ = '-';
 445       break;
 446     case SIGN_NONE:
 447       break;
 448     }
 449
 450   memcpy (p, q, intlen + d + 1);
 451   p += intlen + d;
 452
 453   if (nesign > 0)
 454     {
 455       if (with_exp)
 456          *p++ = exp_char;
 457       switch (esign)
 458         {
 459         case SIGN_PLUS:
 460           *p++ = '+';
 461           break;
 462         case SIGN_MINUS:
 463           *p++ = '-';
 464           break;
 465         case SIGN_NONE:
 466           break;
 467         }
 468       q = itoa (neval);
 469       digits = strlen (q);
 470
 471       for (itmp = 0; itmp < e - digits; itmp++)
 472         *p++ = '0';
 473       memcpy (p, q, digits);
 474       p[digits]  = 0;
 475     }
 476
 477 done:
 478   return ;
 479 }
 480
 481 void
 482 write_l (fnode * f, char *source, int len)
 483 {
 484   char *p;
 485   int64_t n;
 486
 487   p = write_block (f->u.w);
 488   if (p == NULL)
 489     return;
 490
 491   memset (p, ' ', f->u.w - 1);
 492   n = extract_int (source, len);
 493   p[f->u.w - 1] = (n) ? 'T' : 'F';
 494 }
 495
 496 /* Output a real number according to its format.  */
 497
 498 static void
 499 write_float (fnode *f, const char *source, int len)
 500 {
 501   double n;
 502   int nb =0, res;
 503   char * p, fin;
 504   fnode *f2 = NULL;
 505
 506   n = extract_real (source, len);
 507
 508   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 509    {
 510      res = finite (n);
 511      if (res == 0)
 512        {
 513          nb =  f->u.real.w;
 514          p = write_block (nb);
 515          if (nb < 3)
 516          {
 517              memset (p, '*',nb);
 518              return;
 519          }
 520
 521          memset(p, ' ', nb);
 522          res = !isnan (n);
 523          if (res != 0)
 524          {
 525             if (signbit(n))
 526                fin = '-';
 527             else
 528                fin = '+';
 529
 530             if (nb > 7)
 531                memcpy(p + nb - 8, "Infinity", 8);
 532             else
 533                memcpy(p + nb - 3, "Inf", 3);
 534             if (nb < 8 && nb > 3)
 535                p[nb - 4] = fin;
 536             else if (nb > 8)
 537                p[nb - 9] = fin;
 538           }
 539          else
 540              memcpy(p + nb - 3, "NaN", 3);
 541          return;
 542        }
 543    }
 544
 545   if (f->format != FMT_G)
 546     {
 547       output_float (f, n, len);
 548     }
 549   else
 550     {
 551       f2 = calculate_G_format(f, n, len, &nb);
 552       output_float (f2, n, len);
 553       if (f2 != NULL)
 554         free_mem(f2);
 555
 556       if (nb > 0)
 557         {
 558           p = write_block (nb);
 559           memset (p, ' ', nb);
 560         }
 561     }
 562 }
 563
 564
 565 static void
 566 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 567 {
 568   uint32_t ns =0;
 569   uint64_t n = 0;
 570   int w, m, digits, nzero, nblank;
 571   char *p, *q;
 572
 573   w = f->u.integer.w;
 574   m = f->u.integer.m;
 575
 576   n = extract_int (source, len);
 577
 578   /* Special case:  */
 579
 580   if (m == 0 && n == 0)
 581     {
 582       if (w == 0)
 583         w = 1;
 584
 585       p = write_block (w);
 586       if (p == NULL)
 587         return;
 588
 589       memset (p, ' ', w);
 590       goto done;
 591     }
 592
 593
 594   if (len < 8)
 595      {
 596        ns = n;
 597        q = conv (ns);
 598      }
 599   else
 600       q = conv (n);
 601
 602   digits = strlen (q);
 603
 604   /* Select a width if none was specified.  The idea here is to always
 605      print something.  */
 606
 607   if (w == 0)
 608     w = ((digits < m) ? m : digits);
 609
 610   p = write_block (w);
 611   if (p == NULL)
 612     return;
 613
 614   nzero = 0;
 615   if (digits < m)
 616     nzero = m - digits;
 617
 618   /* See if things will work.  */
 619
 620   nblank = w - (nzero + digits);
 621
 622   if (nblank < 0)
 623     {
 624       star_fill (p, w);
 625       goto done;
 626     }
 627
 628   memset (p, ' ', nblank);
 629   p += nblank;
 630
 631   memset (p, '0', nzero);
 632   p += nzero;
 633
 634   memcpy (p, q, digits);
 635
 636 done:
 637   return;
 638 }
 639
 640 static void
 641 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 642 {
 643   int64_t n = 0;
 644   int w, m, digits, nsign, nzero, nblank;
 645   char *p, *q;
 646   sign_t sign;
 647
 648   w = f->u.integer.w;
 649   m = f->u.integer.m;
 650
 651   n = extract_int (source, len);
 652
 653   /* Special case:  */
 654
 655   if (m == 0 && n == 0)
 656     {
 657       if (w == 0)
 658         w = 1;
 659
 660       p = write_block (w);
 661       if (p == NULL)
 662         return;
 663
 664       memset (p, ' ', w);
 665       goto done;
 666     }
 667
 668   sign = calculate_sign (n < 0);
 669   if (n < 0)
 670     n = -n;
 671
 672   nsign = sign == SIGN_NONE ? 0 : 1;
 673   q = conv (n);
 674
 675   digits = strlen (q);
 676
 677   /* Select a width if none was specified.  The idea here is to always
 678      print something.  */
 679
 680   if (w == 0)
 681     w = ((digits < m) ? m : digits) + nsign;
 682
 683   p = write_block (w);
 684   if (p == NULL)
 685     return;
 686
 687   nzero = 0;
 688   if (digits < m)
 689     nzero = m - digits;
 690
 691   /* See if things will work.  */
 692
 693   nblank = w - (nsign + nzero + digits);
 694
 695   if (nblank < 0)
 696     {
 697       star_fill (p, w);
 698       goto done;
 699     }
 700
 701   memset (p, ' ', nblank);
 702   p += nblank;
 703
 704   switch (sign)
 705     {
 706     case SIGN_PLUS:
 707       *p++ = '+';
 708       break;
 709     case SIGN_MINUS:
 710       *p++ = '-';
 711       break;
 712     case SIGN_NONE:
 713       break;
 714     }
 715
 716   memset (p, '0', nzero);
 717   p += nzero;
 718
 719   memcpy (p, q, digits);
 720
 721 done:
 722   return;
 723 }
 724
 725
 726 /* Convert unsigned octal to ascii.  */
 727
 728 static char *
 729 otoa (uint64_t n)
 730 {
 731   char *p;
 732
 733   if (n == 0)
 734     {
 735       scratch[0] = '0';
 736       scratch[1] = '\0';
 737       return scratch;
 738     }
 739
 740   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 741   *p-- = '\0';
 742
 743   while (n != 0)
 744     {
 745       *p = '0' + (n & 7);
 746       p -- ;
 747       n >>= 3;
 748     }
 749
 750   return ++p;
 751 }
 752
 753
 754 /* Convert unsigned binary to ascii.  */
 755
 756 static char *
 757 btoa (uint64_t n)
 758 {
 759   char *p;
 760
 761   if (n == 0)
 762     {
 763       scratch[0] = '0';
 764       scratch[1] = '\0';
 765       return scratch;
 766     }
 767
 768   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 769   *p-- = '\0';
 770
 771   while (n != 0)
 772     {
 773       *p-- = '0' + (n & 1);
 774       n >>= 1;
 775     }
 776
 777   return ++p;
 778 }
 779
 780
 781 void
 782 write_i (fnode * f, const char *p, int len)
 783 {
 784
 785   write_decimal (f, p, len, (void *) itoa);
 786 }
 787
 788
 789 void
 790 write_b (fnode * f, const char *p, int len)
 791 {
 792
 793   write_int (f, p, len, btoa);
 794 }
 795
 796
 797 void
 798 write_o (fnode * f, const char *p, int len)
 799 {
 800
 801   write_int (f, p, len, otoa);
 802 }
 803
 804 void
 805 write_z (fnode * f, const char *p, int len)
 806 {
 807
 808   write_int (f, p, len, xtoa);
 809 }
 810
 811
 812 void
 813 write_d (fnode *f, const char *p, int len)
 814 {
 815
 816   write_float (f, p, len);
 817 }
 818
 819
 820 void
 821 write_e (fnode *f, const char *p, int len)
 822 {
 823
 824   write_float (f, p, len);
 825 }
 826
 827
 828 void
 829 write_f (fnode *f, const char *p, int len)
 830 {
 831
 832   write_float (f, p, len);
 833 }
 834
 835
 836 void
 837 write_en (fnode *f, const char *p, int len)
 838 {
 839
 840   write_float (f, p, len);
 841 }
 842
 843
 844 void
 845 write_es (fnode *f, const char *p, int len)
 846 {
 847
 848   write_float (f, p, len);
 849 }
 850
 851
 852 /* Take care of the X/TR descriptor.  */
 853
 854 void
 855 write_x (fnode * f)
 856 {
 857   char *p;
 858
 859   p = write_block (f->u.n);
 860   if (p == NULL)
 861     return;
 862
 863   memset (p, ' ', f->u.n);
 864 }
 865
 866
 867 /* List-directed writing.  */
 868
 869
 870 /* Write a single character to the output.  Returns nonzero if
 871    something goes wrong.  */
 872
 873 static int
 874 write_char (char c)
 875 {
 876   char *p;
 877
 878   p = write_block (1);
 879   if (p == NULL)
 880     return 1;
 881
 882   *p = c;
 883
 884   return 0;
 885 }
 886
 887
 888 /* Write a list-directed logical value.  */
 889
 890 static void
 891 write_logical (const char *source, int length)
 892 {
 893   write_char (extract_int (source, length) ? 'T' : 'F');
 894 }
 895
 896
 897 /* Write a list-directed integer value.  */
 898
 899 static void
 900 write_integer (const char *source, int length)
 901 {
 902   char *p;
 903   const char *q;
 904   int digits;
 905   int width;
 906
 907   q = itoa (extract_int (source, length));
 908
 909   switch (length)
 910     {
 911     case 1:
 912       width = 4;
 913       break;
 914
 915     case 2:
 916       width = 6;
 917       break;
 918
 919     case 4:
 920       width = 11;
 921       break;
 922
 923     case 8:
 924       width = 20;
 925       break;
 926
 927     default:
 928       width = 0;
 929       break;
 930     }
 931
 932   digits = strlen (q);
 933
 934   if(width < digits )
 935     width = digits ;
 936   p = write_block (width) ;
 937
 938   memset(p ,' ', width - digits) ;
 939   memcpy (p + width - digits, q, digits);
 940 }
 941
 942
 943 /* Write a list-directed string.  We have to worry about delimiting
 944    the strings if the file has been opened in that mode.  */
 945
 946 static void
 947 write_character (const char *source, int length)
 948 {
 949   int i, extra;
 950   char *p, d;
 951
 952   switch (current_unit->flags.delim)
 953     {
 954     case DELIM_APOSTROPHE:
 955       d = '\'';
 956       break;
 957     case DELIM_QUOTE:
 958       d = '"';
 959       break;
 960     default:
 961       d = ' ';
 962       break;
 963     }
 964
 965   if (d == ' ')
 966     extra = 0;
 967   else
 968     {
 969       extra = 2;
 970
 971       for (i = 0; i < length; i++)
 972         if (source[i] == d)
 973           extra++;
 974     }
 975
 976   p = write_block (length + extra);
 977   if (p == NULL)
 978     return;
 979
 980   if (d == ' ')
 981     memcpy (p, source, length);
 982   else
 983     {
 984       *p++ = d;
 985
 986       for (i = 0; i < length; i++)
 987         {
 988           *p++ = source[i];
 989           if (source[i] == d)
 990             *p++ = d;
 991         }
 992
 993       *p = d;
 994     }
 995 }
 996
 997
 998 /* Output a real number with default format.
 999    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1000
1001 static void
1002 write_real (const char *source, int length)
1003 {
1004   fnode f ;
1005   int org_scale = g.scale_factor;
1006   f.format = FMT_G;
1007   g.scale_factor = 1;
1008   if (length < 8)
1009     {
1010       f.u.real.w = 14;
1011       f.u.real.d = 7;
1012       f.u.real.e = 2;
1013     }
1014   else
1015     {
1016       f.u.real.w = 23;
1017       f.u.real.d = 15;
1018       f.u.real.e = 3;
1019     }
1020   write_float (&f, source , length);
1021   g.scale_factor = org_scale;
1022 }
1023
1024
1025 static void
1026 write_complex (const char *source, int len)
1027 {
1028
1029   if (write_char ('('))
1030     return;
1031   write_real (source, len);
1032
1033   if (write_char (','))
1034     return;
1035   write_real (source + len, len);
1036
1037   write_char (')');
1038 }
1039
1040
1041 /* Write the separator between items.  */
1042
1043 static void
1044 write_separator (void)
1045 {
1046   char *p;
1047
1048   p = write_block (options.separator_len);
1049   if (p == NULL)
1050     return;
1051
1052   memcpy (p, options.separator, options.separator_len);
1053 }
1054
1055
1056 /* Write an item with list formatting.
1057    TODO: handle skipping to the next record correctly, particularly
1058    with strings.  */
1059
1060 void
1061 list_formatted_write (bt type, void *p, int len)
1062 {
1063   static int char_flag;
1064
1065   if (current_unit == NULL)
1066     return;
1067
1068   if (g.first_item)
1069     {
1070       g.first_item = 0;
1071       char_flag = 0;
1072       write_char (' ');
1073     }
1074   else
1075     {
1076       if (type != BT_CHARACTER || !char_flag ||
1077           current_unit->flags.delim != DELIM_NONE)
1078         write_separator ();
1079     }
1080
1081   switch (type)
1082     {
1083     case BT_INTEGER:
1084       write_integer (p, len);
1085       break;
1086     case BT_LOGICAL:
1087       write_logical (p, len);
1088       break;
1089     case BT_CHARACTER:
1090       write_character (p, len);
1091       break;
1092     case BT_REAL:
1093       write_real (p, len);
1094       break;
1095     case BT_COMPLEX:
1096       write_complex (p, len);
1097       break;
1098     default:
1099       internal_error ("list_formatted_write(): Bad type");
1100     }
1101
1102   char_flag = (type == BT_CHARACTER);
1103 }
1104
1105 void
1106 namelist_write (void)
1107 {
1108    namelist_info * t1, *t2;
1109    int len,num;
1110    void * p;
1111
1112    num = 0;
1113    write_character("&",1);
1114    write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1115    write_character("\n",1);
1116
1117    if (ionml != NULL)
1118      {
1119        t1 = ionml;
1120        while (t1 != NULL)
1121         {
1122           num ++;
1123           t2 = t1;
1124           t1 = t1->next;
1125           if (t2->var_name)
1126             {
1127               write_character(t2->var_name, strlen(t2->var_name));
1128               write_character("=",1);
1129             }
1130           len = t2->len;
1131           p = t2->mem_pos;
1132           switch (t2->type)
1133             {
1134             case BT_INTEGER:
1135               write_integer (p, len);
1136               break;
1137             case BT_LOGICAL:
1138               write_logical (p, len);
1139               break;
1140             case BT_CHARACTER:
1141               write_character (p, t2->string_length);
1142               break;
1143             case BT_REAL:
1144               write_real (p, len);
1145               break;
1146             case BT_COMPLEX:
1147               write_complex (p, len);
1148               break;
1149             default:
1150               internal_error ("Bad type for namelist write");
1151             }
1152          write_character(",",1);
1153          if (num > 5)
1154            {
1155               num = 0;
1156               write_character("\n",1);
1157            }
1158         }
1159      }
1160      write_character("/",1);
1161
1162 }