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       memcpy (p, source, len);
  54       memset (p + len, ' ', wlen - 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          if (nb <= 4)
 519             nb = 4;
 520          p = write_block (nb);
 521          memset (p, ' ' , 1);
 522
 523          res = isinf (n);
 524          if (res != 0)
 525          {
 526             if (res > 0)
 527                fin = '+';
 528             else
 529                fin = '-';
 530
 531              memset (p + 1, fin, nb - 1);
 532           }
 533          else
 534              sprintf(p + 1, "NaN");
 535          return;
 536        }
 537    }
 538
 539   if (f->format != FMT_G)
 540     {
 541       output_float (f, n, len);
 542     }
 543   else
 544     {
 545       f2 = calculate_G_format(f, n, len, &nb);
 546       output_float (f2, n, len);
 547       if (f2 != NULL)
 548         free_mem(f2);
 549
 550       if (nb > 0)
 551         {
 552           p = write_block (nb);
 553           memset (p, ' ', nb);
 554         }
 555    }
 556 }
 557
 558
 559 static void
 560 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 561 {
 562   uint32_t ns =0;
 563   uint64_t n = 0;
 564   int w, m, digits, nzero, nblank;
 565   char *p, *q;
 566
 567   w = f->u.integer.w;
 568   m = f->u.integer.m;
 569
 570   n = extract_int (source, len);
 571
 572   /* Special case */
 573
 574   if (m == 0 && n == 0)
 575     {
 576       if (w == 0)
 577         w = 1;
 578
 579       p = write_block (w);
 580       if (p == NULL)
 581         return;
 582
 583       memset (p, ' ', w);
 584       goto done;
 585     }
 586
 587
 588   if (len < 8)
 589      {
 590        ns = n;
 591        q = conv (ns);
 592      }
 593   else
 594       q = conv (n);
 595
 596   digits = strlen (q);
 597
 598   /* Select a width if none was specified.  The idea here is to always
 599    * print something. */
 600
 601   if (w == 0)
 602     w = ((digits < m) ? m : digits);
 603
 604   p = write_block (w);
 605   if (p == NULL)
 606     return;
 607
 608   nzero = 0;
 609   if (digits < m)
 610     nzero = m - digits;
 611
 612   /* See if things will work */
 613
 614   nblank = w - (nzero + digits);
 615
 616   if (nblank < 0)
 617     {
 618       star_fill (p, w);
 619       goto done;
 620     }
 621
 622   memset (p, ' ', nblank);
 623   p += nblank;
 624
 625   memset (p, '0', nzero);
 626   p += nzero;
 627
 628   memcpy (p, q, digits);
 629
 630 done:
 631   return;
 632 }
 633
 634 static void
 635 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 636 {
 637   int64_t n = 0;
 638   int w, m, digits, nsign, nzero, nblank;
 639   char *p, *q;
 640   sign_t sign;
 641
 642   w = f->u.integer.w;
 643   m = f->u.integer.m;
 644
 645   n = extract_int (source, len);
 646
 647   /* Special case */
 648
 649   if (m == 0 && n == 0)
 650     {
 651       if (w == 0)
 652         w = 1;
 653
 654       p = write_block (w);
 655       if (p == NULL)
 656         return;
 657
 658       memset (p, ' ', w);
 659       goto done;
 660     }
 661
 662   sign = calculate_sign (n < 0);
 663   if (n < 0)
 664     n = -n;
 665
 666   nsign = sign == SIGN_NONE ? 0 : 1;
 667   q = conv (n);
 668
 669   digits = strlen (q);
 670
 671   /* Select a width if none was specified.  The idea here is to always
 672    * print something. */
 673
 674   if (w == 0)
 675     w = ((digits < m) ? m : digits) + nsign;
 676
 677   p = write_block (w);
 678   if (p == NULL)
 679     return;
 680
 681   nzero = 0;
 682   if (digits < m)
 683     nzero = m - digits;
 684
 685   /* See if things will work */
 686
 687   nblank = w - (nsign + nzero + digits);
 688
 689   if (nblank < 0)
 690     {
 691       star_fill (p, w);
 692       goto done;
 693     }
 694
 695   memset (p, ' ', nblank);
 696   p += nblank;
 697
 698   switch (sign)
 699     {
 700     case SIGN_PLUS:
 701       *p++ = '+';
 702       break;
 703     case SIGN_MINUS:
 704       *p++ = '-';
 705       break;
 706     case SIGN_NONE:
 707       break;
 708     }
 709
 710   memset (p, '0', nzero);
 711   p += nzero;
 712
 713   memcpy (p, q, digits);
 714
 715 done:
 716   return;
 717 }
 718
 719
 720 /* otoa()-- Convert unsigned octal to ascii */
 721
 722 static char *
 723 otoa (uint64_t n)
 724 {
 725   char *p;
 726
 727   if (n == 0)
 728     {
 729       scratch[0] = '0';
 730       scratch[1] = '\0';
 731       return scratch;
 732     }
 733
 734   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 735   *p-- = '\0';
 736
 737   while (n != 0)
 738     {
 739       *p = '0' + (n & 7);
 740       p -- ;
 741       n >>= 3;
 742     }
 743
 744   return ++p;
 745 }
 746
 747
 748 /* btoa()-- Convert unsigned binary to ascii */
 749
 750 static char *
 751 btoa (uint64_t n)
 752 {
 753   char *p;
 754
 755   if (n == 0)
 756     {
 757       scratch[0] = '0';
 758       scratch[1] = '\0';
 759       return scratch;
 760     }
 761
 762   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 763   *p-- = '\0';
 764
 765   while (n != 0)
 766     {
 767       *p-- = '0' + (n & 1);
 768       n >>= 1;
 769     }
 770
 771   return ++p;
 772 }
 773
 774
 775 void
 776 write_i (fnode * f, const char *p, int len)
 777 {
 778
 779   write_decimal (f, p, len, (void *) itoa);
 780 }
 781
 782
 783 void
 784 write_b (fnode * f, const char *p, int len)
 785 {
 786
 787   write_int (f, p, len, btoa);
 788 }
 789
 790
 791 void
 792 write_o (fnode * f, const char *p, int len)
 793 {
 794
 795   write_int (f, p, len, otoa);
 796 }
 797
 798 void
 799 write_z (fnode * f, const char *p, int len)
 800 {
 801
 802   write_int (f, p, len, xtoa);
 803 }
 804
 805
 806 void
 807 write_d (fnode *f, const char *p, int len)
 808 {
 809   write_float (f, p, len);
 810 }
 811
 812
 813 void
 814 write_e (fnode *f, const char *p, int len)
 815 {
 816   write_float (f, p, len);
 817 }
 818
 819
 820 void
 821 write_f (fnode *f, const char *p, int len)
 822 {
 823   write_float (f, p, len);
 824 }
 825
 826
 827 void
 828 write_en (fnode *f, const char *p, int len)
 829 {
 830   write_float (f, p, len);
 831 }
 832
 833
 834 void
 835 write_es (fnode *f, const char *p, int len)
 836 {
 837   write_float (f, p, len);
 838 }
 839
 840
 841 /* write_x()-- Take care of the X/TR descriptor */
 842
 843 void
 844 write_x (fnode * f)
 845 {
 846   char *p;
 847
 848   p = write_block (f->u.n);
 849   if (p == NULL)
 850     return;
 851
 852   memset (p, ' ', f->u.n);
 853 }
 854
 855
 856 /* List-directed writing */
 857
 858
 859 /* write_char()-- Write a single character to the output.  Returns
 860  * nonzero if something goes wrong. */
 861
 862 static int
 863 write_char (char c)
 864 {
 865   char *p;
 866
 867   p = write_block (1);
 868   if (p == NULL)
 869     return 1;
 870
 871   *p = c;
 872
 873   return 0;
 874 }
 875
 876
 877 /* write_logical()-- Write a list-directed logical value */
 878 /* Default logical output should be L2
 879   according to DEC fortran Manual. */
 880 static void
 881 write_logical (const char *source, int length)
 882 {
 883   write_char (' ');
 884   write_char (extract_int (source, length) ? 'T' : 'F');
 885 }
 886
 887
 888 /* write_integer()-- Write a list-directed integer value. */
 889
 890 static void
 891 write_integer (const char *source, int length)
 892 {
 893   char *p;
 894   const char *q;
 895   int digits;
 896   int width = 12;
 897
 898   q = itoa (extract_int (source, length));
 899
 900   digits = strlen (q);
 901
 902   if(width < digits )
 903     width = digits ;
 904   p = write_block (width) ;
 905
 906   memset(p ,' ', width - digits) ;
 907   memcpy (p + width - digits, q, digits);
 908 }
 909
 910
 911 /* write_character()-- Write a list-directed string.  We have to worry
 912  * about delimiting the strings if the file has been opened in that
 913  * mode. */
 914
 915 static void
 916 write_character (const char *source, int length)
 917 {
 918   int i, extra;
 919   char *p, d;
 920
 921   switch (current_unit->flags.delim)
 922     {
 923     case DELIM_APOSTROPHE:
 924       d = '\'';
 925       break;
 926     case DELIM_QUOTE:
 927       d = '"';
 928       break;
 929     default:
 930       d = ' ';
 931       break;
 932     }
 933
 934   if (d == ' ')
 935     extra = 0;
 936   else
 937     {
 938       extra = 2;
 939
 940       for (i = 0; i < length; i++)
 941         if (source[i] == d)
 942           extra++;
 943     }
 944
 945   p = write_block (length + extra);
 946   if (p == NULL)
 947     return;
 948
 949   if (d == ' ')
 950     memcpy (p, source, length);
 951   else
 952     {
 953       *p++ = d;
 954
 955       for (i = 0; i < length; i++)
 956         {
 957           *p++ = source[i];
 958           if (source[i] == d)
 959             *p++ = d;
 960         }
 961
 962       *p = d;
 963     }
 964 }
 965
 966
 967 /* Output the Real number with default format.
 968    According to DEC fortran LRM, default format for
 969    REAL(4) is 1PG15.7E2, and for REAL(8) is 1PG25.15E3  */
 970
 971 static void
 972 write_real (const char *source, int length)
 973 {
 974   fnode f ;
 975   int org_scale = g.scale_factor;
 976   f.format = FMT_G;
 977   g.scale_factor = 1;
 978   if (length < 8)
 979     {
 980       f.u.real.w = 15;
 981       f.u.real.d = 7;
 982       f.u.real.e = 2;
 983     }
 984   else
 985     {
 986       f.u.real.w = 24;
 987       f.u.real.d = 15;
 988       f.u.real.e = 3;
 989     }
 990   write_float (&f, source , length);
 991   g.scale_factor = org_scale;
 992 }
 993
 994
 995 static void
 996 write_complex (const char *source, int len)
 997 {
 998
 999   if (write_char ('('))
1000     return;
1001   write_real (source, len);
1002
1003   if (write_char (','))
1004     return;
1005   write_real (source + len, len);
1006
1007   write_char (')');
1008 }
1009
1010
1011 /* write_separator()-- Write the separator between items. */
1012
1013 static void
1014 write_separator (void)
1015 {
1016   char *p;
1017
1018   p = write_block (options.separator_len);
1019   if (p == NULL)
1020     return;
1021
1022   memcpy (p, options.separator, options.separator_len);
1023 }
1024
1025
1026 /* list_formatted_write()-- Write an item with list formatting.
1027  * TODO: handle skipping to the next record correctly, particularly
1028  * with strings. */
1029
1030 void
1031 list_formatted_write (bt type, void *p, int len)
1032 {
1033   static int char_flag;
1034
1035   if (current_unit == NULL)
1036     return;
1037
1038   if (g.first_item)
1039     {
1040       g.first_item = 0;
1041       char_flag = 0;
1042     }
1043   else
1044     {
1045       if (type != BT_CHARACTER || !char_flag ||
1046           current_unit->flags.delim != DELIM_NONE)
1047         write_separator ();
1048     }
1049
1050   switch (type)
1051     {
1052     case BT_INTEGER:
1053       write_integer (p, len);
1054       break;
1055     case BT_LOGICAL:
1056       write_logical (p, len);
1057       break;
1058     case BT_CHARACTER:
1059       write_character (p, len);
1060       break;
1061     case BT_REAL:
1062       write_real (p, len);
1063       break;
1064     case BT_COMPLEX:
1065       write_complex (p, len);
1066       break;
1067     default:
1068       internal_error ("list_formatted_write(): Bad type");
1069     }
1070
1071   char_flag = (type == BT_CHARACTER);
1072 }
1073
1074 void
1075 namelist_write (void)
1076 {
1077    namelist_info * t1, *t2;
1078    int len,num;
1079    void * p;
1080
1081    num = 0;
1082    write_character("&",1);
1083    write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1084    write_character("\n",1);
1085
1086    if (ionml != NULL)
1087      {
1088        t1 = ionml;
1089        while (t1 != NULL)
1090         {
1091           num ++;
1092           t2 = t1;
1093           t1 = t1->next;
1094           write_character(t2->var_name, strlen(t2->var_name));
1095           write_character("=",1);
1096           len = t2->len;
1097           p = t2->mem_pos;
1098           switch (t2->type)
1099             {
1100             case BT_INTEGER:
1101               write_integer (p, len);
1102               break;
1103             case BT_LOGICAL:
1104               write_logical (p, len);
1105               break;
1106             case BT_CHARACTER:
1107               write_character (p, len);
1108               break;
1109             case BT_REAL:
1110               write_real (p, len);
1111               break;
1112             case BT_COMPLEX:
1113               write_complex (p, len);
1114               break;
1115             default:
1116               internal_error ("Bad type for namelist write");
1117             }
1118          write_character(",",1);
1119          if (num > 5)
1120            {
1121               num = 0;
1122               write_character("\n",1);
1123            }
1124         }
1125      }
1126      write_character("/",1);
1127
1128 }
1129