libgfortran/io/write.c

   1 /* Copyright (C) 2002-2003 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 /* calculate sign()-- Given a flag that indicate if a value is
 108  * negative or not, return a sign_t that gives the sign that we need
 109  * to produce. */
 110
 111 static sign_t
 112 calculate_sign (int negative_flag)
 113 {
 114   sign_t s = SIGN_NONE;
 115
 116   if (negative_flag)
 117     s = SIGN_MINUS;
 118   else
 119     switch (g.sign_status)
 120       {
 121       case SIGN_SP:
 122         s = SIGN_PLUS;
 123         break;
 124       case SIGN_SS:
 125         s = SIGN_NONE;
 126         break;
 127       case SIGN_S:
 128         s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
 129         break;
 130       }
 131
 132   return s;
 133 }
 134
 135
 136 /* calculate_exp()-- returns the value of 10**d.  */
 137
 138 static double
 139 calculate_exp (int d)
 140 {
 141   int i;
 142   double r = 1.0;
 143
 144   for (i = 0; i< (d >= 0 ? d : -d); i++)
 145     r *= 10;
 146
 147   r = (d >= 0) ? r : 1.0 / r;
 148
 149   return r;
 150 }
 151
 152
 153 /* calculate_G_format()-- geneate corresponding I/O format for
 154    FMT_G output.
 155    The rules to translate FMT_G to FMT_E or FNT_F from DEC fortran
 156    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
 157
 158    Data Magnitude                              Equivalent Conversion
 159    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
 160    m = 0                                       F(w-n).(d-1), n' '
 161    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
 162    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
 163    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
 164    ................                           ..........
 165    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
 166    m >= 10**d-0.5                              Ew.d[Ee]
 167
 168    notes: for Gw.d ,  n' ' means 4 blanks
 169           for Gw.dEe, n' ' means e+2 blanks  */
 170
 171 static fnode *
 172 calculate_G_format (fnode *f, double value, int len, int *num_blank)
 173 {
 174   int e = f->u.real.e;
 175   int d = f->u.real.d;
 176   int w = f->u.real.w;
 177   fnode *newf;
 178   double m, exp_d;
 179   int low, high, mid;
 180   int ubound, lbound;
 181
 182   newf = get_mem (sizeof (fnode));
 183
 184   /* Absolute value.  */
 185   m = (value > 0.0) ? value : -value;
 186
 187   /* In case of the two data magnitude ranges,
 188      generate E editing, Ew.d[Ee].  */
 189   exp_d = calculate_exp (d);
 190   if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
 191       || (m >= (double) exp_d - 0.5 ))
 192     {
 193       newf->format = FMT_E;
 194       newf->u.real.w = w;
 195       newf->u.real.d = d;
 196       newf->u.real.e = e;
 197       *num_blank = e + 2;
 198       return newf;
 199     }
 200
 201   /* Use binary search to find the data magnitude range.  */
 202   mid = 0;
 203   low = 0;
 204   high = d + 1;
 205   lbound = 0;
 206   ubound = d + 1;
 207
 208   while (low <= high)
 209     {
 210       double temp;
 211       mid = (low + high) / 2;
 212
 213       /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
 214       temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
 215
 216       if (m < temp)
 217         {
 218           ubound = mid;
 219           if (ubound == lbound + 1)
 220             break;
 221           high = mid - 1;
 222         }
 223       else if (m > temp)
 224         {
 225           lbound = mid;
 226           if (ubound == lbound + 1)
 227             {
 228               mid ++;
 229               break;
 230             }
 231           low = mid + 1;
 232         }
 233       else
 234         break;
 235     }
 236
 237   /* Generate the F editing. F(w-4).(-(mid-d-1)), 4' '.  */
 238   newf->format = FMT_F;
 239   newf->u.real.w = f->u.real.w - 4;
 240
 241   /* Special case.  */
 242   if (m == 0.0)
 243     newf->u.real.d = d - 1;
 244   else
 245     newf->u.real.d = - (mid - d - 1);
 246
 247   *num_blank = 4;
 248
 249   /* For F editing, the scale factor is ignored.  */
 250   g.scale_factor = 0;
 251   return newf;
 252 }
 253
 254
 255 /* output_float() -- output a real number according to its format
 256                      which is FMT_G free */
 257
 258 static void
 259 output_float (fnode *f, double value, int len)
 260 {
 261   int w, d, e, e_new;
 262   int digits;
 263   int nsign, nblank, nesign;
 264   int sca, neval, itmp;
 265   char *p;
 266   const char *q, *intstr, *base;
 267   double n;
 268   format_token ft;
 269   char exp_char = 'E';
 270   int with_exp = 1;
 271   int scale_flag = 1 ;
 272   double minv = 0.0, maxv = 0.0;
 273   sign_t sign = SIGN_NONE, esign = SIGN_NONE;
 274
 275   int intval = 0, intlen = 0;
 276   int j;
 277
 278   /* EXP value for this number */
 279   neval = 0;
 280
 281   /* Width of EXP and it's sign*/
 282   nesign = 0;
 283
 284   ft = f->format;
 285   w = f->u.real.w;
 286   d = f->u.real.d + 1;
 287
 288   /* Width of the EXP */
 289   e = 0;
 290
 291   sca = g.scale_factor;
 292   n = value;
 293
 294   sign = calculate_sign (n < 0.0);
 295   if (n < 0)
 296     n = -n;
 297
 298   /* Width of the sign for the whole number */
 299   nsign = (sign == SIGN_NONE ? 0 : 1);
 300
 301   digits = 0;
 302   if (ft != FMT_F)
 303     {
 304       e = f->u.real.e;
 305     }
 306   if (ft == FMT_F || ft == FMT_E || ft == FMT_D)
 307     {
 308       if (ft == FMT_F)
 309         scale_flag = 0;
 310       if (ft == FMT_D)
 311         exp_char = 'D' ;
 312       minv = 0.1;
 313       maxv = 1.0;
 314
 315       /* Here calculate the new val of the number with consideration
 316          of Globle Scale value */
 317       while (sca >  0)
 318         {
 319           minv *= 10.0;
 320           maxv *= 10.0;
 321           n *= 10.0;
 322           sca -- ;
 323           neval --;
 324         }
 325
 326       /* Now calculate the new Exp value for this number */
 327       sca = g.scale_factor;
 328       while(sca >= 1)
 329         {
 330           sca /= 10;
 331           digits ++ ;
 332         }
 333     }
 334
 335    if (ft == FMT_EN )
 336      {
 337        minv = 1.0;
 338        maxv = 1000.0;
 339      }
 340    if (ft == FMT_ES)
 341      {
 342        minv = 1.0;
 343        maxv = 10.0;
 344      }
 345
 346    /* OK, let's scale the number to appropriate range */
 347    while (scale_flag && n > 0.0 && n < minv)
 348      {
 349        if (n < minv)
 350          {
 351            n = n * 10.0 ;
 352            neval --;
 353          }
 354      }
 355    while (scale_flag && n > 0.0 && n > maxv)
 356      {
 357        if (n > maxv)
 358          {
 359            n = n / 10.0 ;
 360            neval ++;
 361          }
 362      }
 363
 364   /* It is time to process the EXP part of the number.
 365      Value of 'nesign' is 0 unless following codes is executed.
 366   */
 367   if (ft != FMT_F)
 368     {
 369      /* Sign of the EXP value */
 370      if (neval >= 0)
 371        esign = SIGN_PLUS;
 372      else
 373        {
 374          esign = SIGN_MINUS;
 375          neval = - neval ;
 376        }
 377
 378       /* Width of the EXP*/
 379       e_new = 0;
 380       j = neval;
 381       while (j > 0)
 382         {
 383            j = j / 10;
 384            e_new ++ ;
 385         }
 386       if (e <= e_new)
 387          e = e_new;
 388
 389      /* Got the width of EXP */
 390      if (e < digits)
 391        e = digits ;
 392
 393      /* Minimum value of the width would be 2 */
 394      if (e < 2)
 395        e = 2;
 396
 397      nesign =  1 ;  /* We must give a position for the 'exp_char' */
 398      if (e > 0)
 399        nesign = e + nesign + (esign != SIGN_NONE ? 1 : 0);
 400    }
 401
 402
 403   intval = n;
 404   intstr = itoa (intval);
 405   intlen = strlen (intstr);
 406
 407   q = rtoa (n, len, d);
 408   digits = strlen (q);
 409
 410   /* Select a width if none was specified.  */
 411   if (w <= 0)
 412     w = digits + nsign;
 413
 414   p = write_block (w);
 415   if (p == NULL)
 416     return;
 417
 418   base = p;
 419
 420   nblank = w - (nsign + intlen + d + nesign);
 421   if (nblank == -1 && ft != FMT_F)
 422      {
 423        with_exp = 0;
 424        nesign -= 1;
 425        nblank = w - (nsign + intlen + d + nesign);
 426      }
 427   /* don't let a leading '0' cause field overflow */
 428   if (nblank == -1 && ft == FMT_F && q[0] == '0')
 429      {
 430         q++;
 431         nblank = 0;
 432      }
 433
 434   if (nblank < 0)
 435     {
 436       star_fill (p, w);
 437       goto done;
 438     }
 439   memset (p, ' ', nblank);
 440   p += nblank;
 441
 442   switch (sign)
 443     {
 444     case SIGN_PLUS:
 445       *p++ = '+';
 446       break;
 447     case SIGN_MINUS:
 448       *p++ = '-';
 449       break;
 450     case SIGN_NONE:
 451       break;
 452     }
 453
 454   memcpy (p, q, intlen + d + 1);
 455   p += intlen + d;
 456
 457   if (nesign > 0)
 458     {
 459       if (with_exp)
 460          *p++ = exp_char;
 461       switch (esign)
 462         {
 463         case SIGN_PLUS:
 464           *p++ = '+';
 465           break;
 466         case SIGN_MINUS:
 467           *p++ = '-';
 468           break;
 469         case SIGN_NONE:
 470           break;
 471         }
 472       q = itoa (neval);
 473       digits = strlen (q);
 474
 475       for (itmp = 0; itmp < e - digits; itmp++)
 476         *p++ = '0';
 477       memcpy (p, q, digits);
 478       p[digits]  = 0;
 479     }
 480
 481 done:
 482   return ;
 483 }
 484
 485 void
 486 write_l (fnode * f, char *source, int len)
 487 {
 488   char *p;
 489   int64_t n;
 490
 491   p = write_block (f->u.w);
 492   if (p == NULL)
 493     return;
 494
 495   memset (p, ' ', f->u.w - 1);
 496   n = extract_int (source, len);
 497   p[f->u.w - 1] = (n) ? 'T' : 'F';
 498 }
 499
 500 /* write_float() -- output a real number according to its format */
 501
 502 static void
 503 write_float (fnode *f, const char *source, int len)
 504 {
 505   double n;
 506   int nb =0, res;
 507   char * p, fin;
 508   fnode *f2 = NULL;
 509
 510   n = extract_real (source, len);
 511
 512   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 513    {
 514      res = finite (n);
 515      if (res == 0)
 516        {
 517          nb =  f->u.real.w;
 518          p = write_block (nb);
 519          if (nb < 3)
 520          {
 521              memset (p, '*',nb);
 522              return;
 523          }
 524
 525          memset(p, ' ', nb);
 526          res = isinf (n);
 527          if (res != 0)
 528          {
 529             if (res > 0)
 530                fin = '+';
 531             else
 532                fin = '-';
 533
 534             if (nb > 7)
 535                memcpy(p + nb - 8, "Infinity", 8);
 536             else
 537                memcpy(p + nb - 3, "Inf", 3);
 538             if (nb < 8)
 539                memset(p + nb - 4, fin, 1);
 540             else if (nb > 8)
 541                memset(p + nb - 9, fin, 1);
 542           }
 543          else
 544              memcpy(p + nb - 3, "NaN", 3);
 545          return;
 546        }
 547    }
 548
 549   if (f->format != FMT_G)
 550     {
 551       output_float (f, n, len);
 552     }
 553   else
 554     {
 555       f2 = calculate_G_format(f, n, len, &nb);
 556       output_float (f2, n, len);
 557       if (f2 != NULL)
 558         free_mem(f2);
 559
 560       if (nb > 0)
 561         {
 562           p = write_block (nb);
 563           memset (p, ' ', nb);
 564         }
 565    }
 566 }
 567
 568
 569 static void
 570 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 571 {
 572   uint32_t ns =0;
 573   uint64_t n = 0;
 574   int w, m, digits, nzero, nblank;
 575   char *p, *q;
 576
 577   w = f->u.integer.w;
 578   m = f->u.integer.m;
 579
 580   n = extract_int (source, len);
 581
 582   /* Special case */
 583
 584   if (m == 0 && n == 0)
 585     {
 586       if (w == 0)
 587         w = 1;
 588
 589       p = write_block (w);
 590       if (p == NULL)
 591         return;
 592
 593       memset (p, ' ', w);
 594       goto done;
 595     }
 596
 597
 598   if (len < 8)
 599      {
 600        ns = n;
 601        q = conv (ns);
 602      }
 603   else
 604       q = conv (n);
 605
 606   digits = strlen (q);
 607
 608   /* Select a width if none was specified.  The idea here is to always
 609    * print something. */
 610
 611   if (w == 0)
 612     w = ((digits < m) ? m : digits);
 613
 614   p = write_block (w);
 615   if (p == NULL)
 616     return;
 617
 618   nzero = 0;
 619   if (digits < m)
 620     nzero = m - digits;
 621
 622   /* See if things will work */
 623
 624   nblank = w - (nzero + digits);
 625
 626   if (nblank < 0)
 627     {
 628       star_fill (p, w);
 629       goto done;
 630     }
 631
 632   memset (p, ' ', nblank);
 633   p += nblank;
 634
 635   memset (p, '0', nzero);
 636   p += nzero;
 637
 638   memcpy (p, q, digits);
 639
 640 done:
 641   return;
 642 }
 643
 644 static void
 645 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 646 {
 647   int64_t n = 0;
 648   int w, m, digits, nsign, nzero, nblank;
 649   char *p, *q;
 650   sign_t sign;
 651
 652   w = f->u.integer.w;
 653   m = f->u.integer.m;
 654
 655   n = extract_int (source, len);
 656
 657   /* Special case */
 658
 659   if (m == 0 && n == 0)
 660     {
 661       if (w == 0)
 662         w = 1;
 663
 664       p = write_block (w);
 665       if (p == NULL)
 666         return;
 667
 668       memset (p, ' ', w);
 669       goto done;
 670     }
 671
 672   sign = calculate_sign (n < 0);
 673   if (n < 0)
 674     n = -n;
 675
 676   nsign = sign == SIGN_NONE ? 0 : 1;
 677   q = conv (n);
 678
 679   digits = strlen (q);
 680
 681   /* Select a width if none was specified.  The idea here is to always
 682    * print something. */
 683
 684   if (w == 0)
 685     w = ((digits < m) ? m : digits) + nsign;
 686
 687   p = write_block (w);
 688   if (p == NULL)
 689     return;
 690
 691   nzero = 0;
 692   if (digits < m)
 693     nzero = m - digits;
 694
 695   /* See if things will work */
 696
 697   nblank = w - (nsign + nzero + digits);
 698
 699   if (nblank < 0)
 700     {
 701       star_fill (p, w);
 702       goto done;
 703     }
 704
 705   memset (p, ' ', nblank);
 706   p += nblank;
 707
 708   switch (sign)
 709     {
 710     case SIGN_PLUS:
 711       *p++ = '+';
 712       break;
 713     case SIGN_MINUS:
 714       *p++ = '-';
 715       break;
 716     case SIGN_NONE:
 717       break;
 718     }
 719
 720   memset (p, '0', nzero);
 721   p += nzero;
 722
 723   memcpy (p, q, digits);
 724
 725 done:
 726   return;
 727 }
 728
 729
 730 /* otoa()-- Convert unsigned octal to ascii */
 731
 732 static char *
 733 otoa (uint64_t n)
 734 {
 735   char *p;
 736
 737   if (n == 0)
 738     {
 739       scratch[0] = '0';
 740       scratch[1] = '\0';
 741       return scratch;
 742     }
 743
 744   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 745   *p-- = '\0';
 746
 747   while (n != 0)
 748     {
 749       *p = '0' + (n & 7);
 750       p -- ;
 751       n >>= 3;
 752     }
 753
 754   return ++p;
 755 }
 756
 757
 758 /* btoa()-- Convert unsigned binary to ascii */
 759
 760 static char *
 761 btoa (uint64_t n)
 762 {
 763   char *p;
 764
 765   if (n == 0)
 766     {
 767       scratch[0] = '0';
 768       scratch[1] = '\0';
 769       return scratch;
 770     }
 771
 772   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 773   *p-- = '\0';
 774
 775   while (n != 0)
 776     {
 777       *p-- = '0' + (n & 1);
 778       n >>= 1;
 779     }
 780
 781   return ++p;
 782 }
 783
 784
 785 void
 786 write_i (fnode * f, const char *p, int len)
 787 {
 788
 789   write_decimal (f, p, len, (void *) itoa);
 790 }
 791
 792
 793 void
 794 write_b (fnode * f, const char *p, int len)
 795 {
 796
 797   write_int (f, p, len, btoa);
 798 }
 799
 800
 801 void
 802 write_o (fnode * f, const char *p, int len)
 803 {
 804
 805   write_int (f, p, len, otoa);
 806 }
 807
 808 void
 809 write_z (fnode * f, const char *p, int len)
 810 {
 811
 812   write_int (f, p, len, xtoa);
 813 }
 814
 815
 816 void
 817 write_d (fnode *f, const char *p, int len)
 818 {
 819   write_float (f, p, len);
 820 }
 821
 822
 823 void
 824 write_e (fnode *f, const char *p, int len)
 825 {
 826   write_float (f, p, len);
 827 }
 828
 829
 830 void
 831 write_f (fnode *f, const char *p, int len)
 832 {
 833   write_float (f, p, len);
 834 }
 835
 836
 837 void
 838 write_en (fnode *f, const char *p, int len)
 839 {
 840   write_float (f, p, len);
 841 }
 842
 843
 844 void
 845 write_es (fnode *f, const char *p, int len)
 846 {
 847   write_float (f, p, len);
 848 }
 849
 850
 851 /* write_x()-- Take care of the X/TR descriptor */
 852
 853 void
 854 write_x (fnode * f)
 855 {
 856   char *p;
 857
 858   p = write_block (f->u.n);
 859   if (p == NULL)
 860     return;
 861
 862   memset (p, ' ', f->u.n);
 863 }
 864
 865
 866 /* List-directed writing */
 867
 868
 869 /* write_char()-- Write a single character to the output.  Returns
 870  * nonzero if something goes wrong. */
 871
 872 static int
 873 write_char (char c)
 874 {
 875   char *p;
 876
 877   p = write_block (1);
 878   if (p == NULL)
 879     return 1;
 880
 881   *p = c;
 882
 883   return 0;
 884 }
 885
 886
 887 /* write_logical()-- Write a list-directed logical value */
 888
 889 static void
 890 write_logical (const char *source, int length)
 891 {
 892   write_char (extract_int (source, length) ? 'T' : 'F');
 893 }
 894
 895
 896 /* write_integer()-- Write a list-directed integer value. */
 897
 898 static void
 899 write_integer (const char *source, int length)
 900 {
 901   char *p;
 902   const char *q;
 903   int digits;
 904   int width;
 905
 906   q = itoa (extract_int (source, length));
 907
 908   switch (length)
 909     {
 910     case 1:
 911       width = 4;
 912       break;
 913
 914     case 2:
 915       width = 6;
 916       break;
 917
 918     case 4:
 919       width = 11;
 920       break;
 921
 922     case 8:
 923       width = 20;
 924       break;
 925
 926     default:
 927       width = 0;
 928       break;
 929     }
 930
 931   digits = strlen (q);
 932
 933   if(width < digits )
 934     width = digits ;
 935   p = write_block (width) ;
 936
 937   memset(p ,' ', width - digits) ;
 938   memcpy (p + width - digits, q, digits);
 939 }
 940
 941
 942 /* write_character()-- Write a list-directed string.  We have to worry
 943  * about delimiting the strings if the file has been opened in that
 944  * 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 the Real number with default format.
 999    REAL(4) is 1PG14.7E2, and REAL(8) is 1PG23.15E3  */
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_separator()-- 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 /* list_formatted_write()-- 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           write_character(t2->var_name, strlen(t2->var_name));
1126           write_character("=",1);
1127           len = t2->len;
1128           p = t2->mem_pos;
1129           switch (t2->type)
1130             {
1131             case BT_INTEGER:
1132               write_integer (p, len);
1133               break;
1134             case BT_LOGICAL:
1135               write_logical (p, len);
1136               break;
1137             case BT_CHARACTER:
1138               write_character (p, len);
1139               break;
1140             case BT_REAL:
1141               write_real (p, len);
1142               break;
1143             case BT_COMPLEX:
1144               write_complex (p, len);
1145               break;
1146             default:
1147               internal_error ("Bad type for namelist write");
1148             }
1149          write_character(",",1);
1150          if (num > 5)
1151            {
1152               num = 0;
1153               write_character("\n",1);
1154            }
1155         }
1156      }
1157      write_character("/",1);
1158
1159 }
1160