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 <stdio.h>
  25 #include <stdlib.h>
  26 #include "libgfortran.h"
  27 #include "io.h"
  28
  29
  30 #define star_fill(p, n) memset(p, '*', n)
  31
  32
  33 typedef enum
  34 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
  35 sign_t;
  36
  37
  38 void
  39 write_a (fnode * f, const char *source, int len)
  40 {
  41   int wlen;
  42   char *p;
  43
  44   wlen = f->u.string.length < 0 ? len : f->u.string.length;
  45
  46   p = write_block (wlen);
  47   if (p == NULL)
  48     return;
  49
  50   if (wlen < len)
  51     memcpy (p, source, wlen);
  52   else
  53     {
  54       memset (p, ' ', wlen - len);
  55       memcpy (p + wlen - len, source, len);
  56     }
  57 }
  58
  59 static int64_t
  60 extract_int (const void *p, int len)
  61 {
  62   int64_t i = 0;
  63
  64   if (p == NULL)
  65     return i;
  66
  67   switch (len)
  68     {
  69     case 1:
  70       i = *((const int8_t *) p);
  71       break;
  72     case 2:
  73       i = *((const int16_t *) p);
  74       break;
  75     case 4:
  76       i = *((const int32_t *) p);
  77       break;
  78     case 8:
  79       i = *((const int64_t *) p);
  80       break;
  81     default:
  82       internal_error ("bad integer kind");
  83     }
  84
  85   return i;
  86 }
  87
  88 static double
  89 extract_real (const void *p, int len)
  90 {
  91   double i = 0.0;
  92   switch (len)
  93     {
  94     case 4:
  95       i = *((const float *) p);
  96       break;
  97     case 8:
  98       i = *((const double *) p);
  99       break;
 100     default:
 101       internal_error ("bad real kind");
 102     }
 103   return i;
 104
 105 }
 106
 107
 108 /* Given a flag that indicate if a value is negative or not, return a
 109    sign_t that gives the sign that we need 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 /* 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 /* Generate corresponding I/O format for FMT_G output.
 154    The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
 155    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
 156
 157    Data Magnitude                              Equivalent Conversion
 158    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
 159    m = 0                                       F(w-n).(d-1), n' '
 160    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
 161    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
 162    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
 163    ................                           ..........
 164    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
 165    m >= 10**d-0.5                              Ew.d[Ee]
 166
 167    notes: for Gw.d ,  n' ' means 4 blanks
 168           for Gw.dEe, n' ' means e+2 blanks  */
 169
 170 static fnode *
 171 calculate_G_format (fnode *f, double value, int len, int *num_blank)
 172 {
 173   int e = f->u.real.e;
 174   int d = f->u.real.d;
 175   int w = f->u.real.w;
 176   fnode *newf;
 177   double m, exp_d;
 178   int low, high, mid;
 179   int ubound, lbound;
 180
 181   newf = get_mem (sizeof (fnode));
 182
 183   /* Absolute value.  */
 184   m = (value > 0.0) ? value : -value;
 185
 186   /* In case of the two data magnitude ranges,
 187      generate E editing, Ew.d[Ee].  */
 188   exp_d = calculate_exp (d);
 189   if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
 190       || (m >= (double) exp_d - 0.5 ))
 191     {
 192       newf->format = FMT_E;
 193       newf->u.real.w = w;
 194       newf->u.real.d = d;
 195       newf->u.real.e = e;
 196       *num_blank = 0;
 197       return newf;
 198     }
 199
 200   /* Use binary search to find the data magnitude range.  */
 201   mid = 0;
 202   low = 0;
 203   high = d + 1;
 204   lbound = 0;
 205   ubound = d + 1;
 206
 207   while (low <= high)
 208     {
 209       double temp;
 210       mid = (low + high) / 2;
 211
 212       /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
 213       temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
 214
 215       if (m < temp)
 216         {
 217           ubound = mid;
 218           if (ubound == lbound + 1)
 219             break;
 220           high = mid - 1;
 221         }
 222       else if (m > temp)
 223         {
 224           lbound = mid;
 225           if (ubound == lbound + 1)
 226             {
 227               mid ++;
 228               break;
 229             }
 230           low = mid + 1;
 231         }
 232       else
 233         break;
 234     }
 235
 236   /* Pad with blanks where the exponent would be.  */
 237   if (e < 0)
 238     *num_blank = 4;
 239   else
 240     *num_blank = e + 2;
 241
 242   /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '.  */
 243   newf->format = FMT_F;
 244   newf->u.real.w = f->u.real.w - *num_blank;
 245
 246   /* Special case.  */
 247   if (m == 0.0)
 248     newf->u.real.d = d - 1;
 249   else
 250     newf->u.real.d = - (mid - d - 1);
 251
 252   /* For F editing, the scale factor is ignored.  */
 253   g.scale_factor = 0;
 254   return newf;
 255 }
 256
 257
 258 /* Output a real number according to its format which is FMT_G free.  */
 259
 260 static void
 261 output_float (fnode *f, double value, int len)
 262 {
 263   /* This must be large enough to accurately hold any value.  */
 264   char buffer[32];
 265   char *out;
 266   char *digits;
 267   int e;
 268   char expchar;
 269   format_token ft;
 270   int w;
 271   int d;
 272   int edigits;
 273   int ndigits;
 274   /* Number of digits before the decimal point.  */
 275   int nbefore;
 276   /* Number of zeros after the decimal point.  */
 277   int nzero;
 278   /* Number of digits after the decimal point.  */
 279   int nafter;
 280   int leadzero;
 281   int nblanks;
 282   int i;
 283   sign_t sign;
 284
 285   ft = f->format;
 286   w = f->u.real.w;
 287   d = f->u.real.d;
 288
 289   /* We should always know the field width and precision.  */
 290   if (d < 0)
 291     internal_error ("Uspecified precision");
 292
 293   /* Use sprintf to print the number in the format +D.DDDDe+ddd
 294      For an N digit exponent, this gives us (32-6)-N digits after the
 295      decimal point, plus another one before the decimal point.  */
 296   sign = calculate_sign (value < 0.0);
 297   if (value < 0)
 298     value = -value;
 299
 300   /* Printf always prints at least two exponent digits.  */
 301   if (value == 0)
 302     edigits = 2;
 303   else
 304     {
 305       edigits = 1 + (int) log10 (fabs(log10 (value)));
 306       if (edigits < 2)
 307         edigits = 2;
 308     }
 309
 310   if (ft == FMT_F || ft == FMT_EN
 311       || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
 312     {
 313       /* Always convert at full precision to avoid double rounding.  */
 314       ndigits = 27 - edigits;
 315     }
 316   else
 317     {
 318       /* We know the number of digits, so can let printf do the rounding
 319          for us.  */
 320       if (ft == FMT_ES)
 321         ndigits = d + 1;
 322       else
 323         ndigits = d;
 324       if (ndigits > 27 - edigits)
 325         ndigits = 27 - edigits;
 326     }
 327
 328   sprintf (buffer, "%+-#31.*e", ndigits - 1, value);
 329
 330   /* Check the resulting string has punctuation in the correct places.  */
 331   if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
 332       internal_error ("printf is broken");
 333
 334   /* Read the exponent back in.  */
 335   e = atoi (&buffer[ndigits + 3]) + 1;
 336
 337   /* Make sure zero comes out as 0.0e0.  */
 338   if (value == 0.0)
 339     e = 0;
 340
 341   /* Normalize the fractional component.  */
 342   buffer[2] = buffer[1];
 343   digits = &buffer[2];
 344
 345   /* Figure out where to place the decimal point.  */
 346   switch (ft)
 347     {
 348     case FMT_F:
 349       nbefore = e + g.scale_factor;
 350       if (nbefore < 0)
 351         {
 352           nzero = -nbefore;
 353           if (nzero > d)
 354             nzero = d;
 355           nafter = d - nzero;
 356           nbefore = 0;
 357         }
 358       else
 359         {
 360           nzero = 0;
 361           nafter = d;
 362         }
 363       expchar = 0;
 364       break;
 365
 366     case FMT_E:
 367     case FMT_D:
 368       i = g.scale_factor;
 369       e -= i;
 370       if (i < 0)
 371         {
 372           nbefore = 0;
 373           nzero = -i;
 374           nafter = d + i;
 375         }
 376       else if (i > 0)
 377         {
 378           nbefore = i;
 379           nzero = 0;
 380           nafter = (d - i) + 1;
 381         }
 382       else /* i == 0 */
 383         {
 384           nbefore = 0;
 385           nzero = 0;
 386           nafter = d;
 387         }
 388
 389       if (ft = FMT_E)
 390         expchar = 'E';
 391       else
 392         expchar = 'D';
 393       break;
 394
 395     case FMT_EN:
 396       /* The exponent must be a multiple of three, with 1-3 digits before
 397          the decimal point.  */
 398       e--;
 399       if (e >= 0)
 400         nbefore = e % 3;
 401       else
 402         {
 403           nbefore = (-e) % 3;
 404           if (nbefore != 0)
 405             nbefore = 3 - nbefore;
 406         }
 407       e -= nbefore;
 408       nbefore++;
 409       nzero = 0;
 410       nafter = d;
 411       expchar = 'E';
 412       break;
 413
 414     case FMT_ES:
 415       e--;
 416       nbefore = 1;
 417       nzero = 0;
 418       nafter = d;
 419       expchar = 'E';
 420       break;
 421
 422     default:
 423       /* Should never happen.  */
 424       internal_error ("Unexpected format token");
 425     }
 426
 427   /* Round the value.  */
 428   if (nbefore + nafter == 0)
 429     ndigits = 0;
 430   else if (nbefore + nafter < ndigits)
 431     {
 432       ndigits = nbefore + nafter;
 433       i = ndigits;
 434       if (digits[i] >= '5')
 435         {
 436           /* Propagate the carry.  */
 437           for (i--; i >= 0; i--)
 438             {
 439               if (digits[i] != '9')
 440                 {
 441                   digits[i]++;
 442                   break;
 443                 }
 444               digits[i] = '0';
 445             }
 446
 447           if (i < 0)
 448             {
 449               /* The carry overflowed.  Fortunately we have some spare space
 450                  at the start of the buffer.  We may discard some digits, but
 451                  this is ok because we already know they are zero.  */
 452               digits--;
 453               digits[0] = '1';
 454               if (ft == FMT_F)
 455                 {
 456                   if (nzero > 0)
 457                     {
 458                       nzero--;
 459                       nafter++;
 460                     }
 461                   else
 462                     nbefore++;
 463                 }
 464               else if (ft == FMT_EN)
 465                 {
 466                   nbefore++;
 467                   if (nbefore == 4)
 468                     {
 469                       nbefore = 1;
 470                       e += 3;
 471                     }
 472                 }
 473               else
 474                 e++;
 475             }
 476         }
 477     }
 478
 479   /* Calculate the format of the exponent field.  */
 480   if (expchar)
 481     {
 482       edigits = 1;
 483       for (i = abs (e); i >= 10; i /= 10)
 484         edigits++;
 485
 486       if (f->u.real.e < 0)
 487         {
 488           /* Width not specified.  Must be no more than 3 digits.  */
 489           if (e > 999 || e < -999)
 490             edigits = -1;
 491           else
 492             {
 493               edigits = 4;
 494               if (e > 99 || e < -99)
 495                 expchar = ' ';
 496             }
 497         }
 498       else
 499         {
 500           /* Exponent width specified, check it is wide enough.  */
 501           if (edigits > f->u.real.e)
 502             edigits = -1;
 503           else
 504             edigits = f->u.real.e + 2;
 505         }
 506     }
 507   else
 508     edigits = 0;
 509
 510   /* Pick a field size if none was specified.  */
 511   if (w <= 0)
 512     w = nbefore + nzero + nafter + 2;
 513
 514   /* Create the ouput buffer.  */
 515   out = write_block (w);
 516   if (out == NULL)
 517     return;
 518
 519   /* Zero values always output as positive, even if the value was negative
 520      before rounding.  */
 521   for (i = 0; i < ndigits; i++)
 522     {
 523       if (digits[i] != '0')
 524         break;
 525     }
 526   if (i == ndigits)
 527     sign = calculate_sign (0);
 528
 529   /* Work out how much padding is needed.  */
 530   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
 531   if (sign != SIGN_NONE)
 532     nblanks--;
 533
 534   /* Check the value fits in the specified field width.  */
 535   if (nblanks < 0 || edigits == -1)
 536     {
 537       star_fill (out, w);
 538       return;
 539     }
 540
 541   /* See if we have space for a zero before the decimal point.  */
 542   if (nbefore == 0 && nblanks > 0)
 543     {
 544       leadzero = 1;
 545       nblanks--;
 546     }
 547   else
 548     leadzero = 0;
 549
 550   /* Padd to full field width.  */
 551   if (nblanks > 0)
 552     {
 553       memset (out, ' ', nblanks);
 554       out += nblanks;
 555     }
 556
 557   /* Output the initial sign (if any).  */
 558   if (sign == SIGN_PLUS)
 559     *(out++) = '+';
 560   else if (sign == SIGN_MINUS)
 561     *(out++) = '-';
 562
 563   /* Output an optional leading zero.  */
 564   if (leadzero)
 565     *(out++) = '0';
 566
 567   /* Output the part before the decimal point, padding with zeros.  */
 568   if (nbefore > 0)
 569     {
 570       if (nbefore > ndigits)
 571         i = ndigits;
 572       else
 573         i = nbefore;
 574
 575       memcpy (out, digits, i);
 576       while (i < nbefore)
 577         out[i++] = '0';
 578
 579       digits += i;
 580       ndigits -= i;
 581       out += nbefore;
 582     }
 583   /* Output the decimal point.  */
 584   *(out++) = '.';
 585
 586   /* Output leading zeros after the decimal point.  */
 587   if (nzero > 0)
 588     {
 589       for (i = 0; i < nzero; i++)
 590         *(out++) = '0';
 591     }
 592
 593   /* Output digits after the decimal point, padding with zeros.  */
 594   if (nafter > 0)
 595     {
 596       if (nafter > ndigits)
 597         i = ndigits;
 598       else
 599         i = nafter;
 600
 601       memcpy (out, digits, i);
 602       while (i < nafter)
 603         out[i++] = '0';
 604
 605       digits += i;
 606       ndigits -= i;
 607       out += nafter;
 608     }
 609
 610   /* Output the exponent.  */
 611   if (expchar)
 612     {
 613       if (expchar != ' ')
 614         {
 615           *(out++) = expchar;
 616           edigits--;
 617         }
 618       snprintf (buffer, 32, "%+0*d", edigits, e);
 619       memcpy (out, buffer, edigits);
 620     }
 621 }
 622
 623
 624 void
 625 write_l (fnode * f, char *source, int len)
 626 {
 627   char *p;
 628   int64_t n;
 629
 630   p = write_block (f->u.w);
 631   if (p == NULL)
 632     return;
 633
 634   memset (p, ' ', f->u.w - 1);
 635   n = extract_int (source, len);
 636   p[f->u.w - 1] = (n) ? 'T' : 'F';
 637 }
 638
 639 /* Output a real number according to its format.  */
 640
 641 static void
 642 write_float (fnode *f, const char *source, int len)
 643 {
 644   double n;
 645   int nb =0, res;
 646   char * p, fin;
 647   fnode *f2 = NULL;
 648
 649   n = extract_real (source, len);
 650
 651   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 652    {
 653      res = finite (n);
 654      if (res == 0)
 655        {
 656          nb =  f->u.real.w;
 657          p = write_block (nb);
 658          if (nb < 3)
 659          {
 660              memset (p, '*',nb);
 661              return;
 662          }
 663
 664          memset(p, ' ', nb);
 665          res = !isnan (n);
 666          if (res != 0)
 667          {
 668             if (signbit(n))
 669                fin = '-';
 670             else
 671                fin = '+';
 672
 673             if (nb > 7)
 674                memcpy(p + nb - 8, "Infinity", 8);
 675             else
 676                memcpy(p + nb - 3, "Inf", 3);
 677             if (nb < 8 && nb > 3)
 678                p[nb - 4] = fin;
 679             else if (nb > 8)
 680                p[nb - 9] = fin;
 681           }
 682          else
 683              memcpy(p + nb - 3, "NaN", 3);
 684          return;
 685        }
 686    }
 687
 688   if (f->format != FMT_G)
 689     {
 690       output_float (f, n, len);
 691     }
 692   else
 693     {
 694       f2 = calculate_G_format(f, n, len, &nb);
 695       output_float (f2, n, len);
 696       if (f2 != NULL)
 697         free_mem(f2);
 698
 699       if (nb > 0)
 700         {
 701           p = write_block (nb);
 702           memset (p, ' ', nb);
 703         }
 704     }
 705 }
 706
 707
 708 static void
 709 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 710 {
 711   uint32_t ns =0;
 712   uint64_t n = 0;
 713   int w, m, digits, nzero, nblank;
 714   char *p, *q;
 715
 716   w = f->u.integer.w;
 717   m = f->u.integer.m;
 718
 719   n = extract_int (source, len);
 720
 721   /* Special case:  */
 722
 723   if (m == 0 && n == 0)
 724     {
 725       if (w == 0)
 726         w = 1;
 727
 728       p = write_block (w);
 729       if (p == NULL)
 730         return;
 731
 732       memset (p, ' ', w);
 733       goto done;
 734     }
 735
 736
 737   if (len < 8)
 738      {
 739        ns = n;
 740        q = conv (ns);
 741      }
 742   else
 743       q = conv (n);
 744
 745   digits = strlen (q);
 746
 747   /* Select a width if none was specified.  The idea here is to always
 748      print something.  */
 749
 750   if (w == 0)
 751     w = ((digits < m) ? m : digits);
 752
 753   p = write_block (w);
 754   if (p == NULL)
 755     return;
 756
 757   nzero = 0;
 758   if (digits < m)
 759     nzero = m - digits;
 760
 761   /* See if things will work.  */
 762
 763   nblank = w - (nzero + digits);
 764
 765   if (nblank < 0)
 766     {
 767       star_fill (p, w);
 768       goto done;
 769     }
 770
 771   memset (p, ' ', nblank);
 772   p += nblank;
 773
 774   memset (p, '0', nzero);
 775   p += nzero;
 776
 777   memcpy (p, q, digits);
 778
 779 done:
 780   return;
 781 }
 782
 783 static void
 784 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 785 {
 786   int64_t n = 0;
 787   int w, m, digits, nsign, nzero, nblank;
 788   char *p, *q;
 789   sign_t sign;
 790
 791   w = f->u.integer.w;
 792   m = f->u.integer.m;
 793
 794   n = extract_int (source, len);
 795
 796   /* Special case:  */
 797
 798   if (m == 0 && n == 0)
 799     {
 800       if (w == 0)
 801         w = 1;
 802
 803       p = write_block (w);
 804       if (p == NULL)
 805         return;
 806
 807       memset (p, ' ', w);
 808       goto done;
 809     }
 810
 811   sign = calculate_sign (n < 0);
 812   if (n < 0)
 813     n = -n;
 814
 815   nsign = sign == SIGN_NONE ? 0 : 1;
 816   q = conv (n);
 817
 818   digits = strlen (q);
 819
 820   /* Select a width if none was specified.  The idea here is to always
 821      print something.  */
 822
 823   if (w == 0)
 824     w = ((digits < m) ? m : digits) + nsign;
 825
 826   p = write_block (w);
 827   if (p == NULL)
 828     return;
 829
 830   nzero = 0;
 831   if (digits < m)
 832     nzero = m - digits;
 833
 834   /* See if things will work.  */
 835
 836   nblank = w - (nsign + nzero + digits);
 837
 838   if (nblank < 0)
 839     {
 840       star_fill (p, w);
 841       goto done;
 842     }
 843
 844   memset (p, ' ', nblank);
 845   p += nblank;
 846
 847   switch (sign)
 848     {
 849     case SIGN_PLUS:
 850       *p++ = '+';
 851       break;
 852     case SIGN_MINUS:
 853       *p++ = '-';
 854       break;
 855     case SIGN_NONE:
 856       break;
 857     }
 858
 859   memset (p, '0', nzero);
 860   p += nzero;
 861
 862   memcpy (p, q, digits);
 863
 864 done:
 865   return;
 866 }
 867
 868
 869 /* Convert unsigned octal to ascii.  */
 870
 871 static char *
 872 otoa (uint64_t n)
 873 {
 874   char *p;
 875
 876   if (n == 0)
 877     {
 878       scratch[0] = '0';
 879       scratch[1] = '\0';
 880       return scratch;
 881     }
 882
 883   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 884   *p-- = '\0';
 885
 886   while (n != 0)
 887     {
 888       *p = '0' + (n & 7);
 889       p -- ;
 890       n >>= 3;
 891     }
 892
 893   return ++p;
 894 }
 895
 896
 897 /* Convert unsigned binary to ascii.  */
 898
 899 static char *
 900 btoa (uint64_t n)
 901 {
 902   char *p;
 903
 904   if (n == 0)
 905     {
 906       scratch[0] = '0';
 907       scratch[1] = '\0';
 908       return scratch;
 909     }
 910
 911   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 912   *p-- = '\0';
 913
 914   while (n != 0)
 915     {
 916       *p-- = '0' + (n & 1);
 917       n >>= 1;
 918     }
 919
 920   return ++p;
 921 }
 922
 923
 924 void
 925 write_i (fnode * f, const char *p, int len)
 926 {
 927
 928   write_decimal (f, p, len, (void *) itoa);
 929 }
 930
 931
 932 void
 933 write_b (fnode * f, const char *p, int len)
 934 {
 935
 936   write_int (f, p, len, btoa);
 937 }
 938
 939
 940 void
 941 write_o (fnode * f, const char *p, int len)
 942 {
 943
 944   write_int (f, p, len, otoa);
 945 }
 946
 947 void
 948 write_z (fnode * f, const char *p, int len)
 949 {
 950
 951   write_int (f, p, len, xtoa);
 952 }
 953
 954
 955 void
 956 write_d (fnode *f, const char *p, int len)
 957 {
 958
 959   write_float (f, p, len);
 960 }
 961
 962
 963 void
 964 write_e (fnode *f, const char *p, int len)
 965 {
 966
 967   write_float (f, p, len);
 968 }
 969
 970
 971 void
 972 write_f (fnode *f, const char *p, int len)
 973 {
 974
 975   write_float (f, p, len);
 976 }
 977
 978
 979 void
 980 write_en (fnode *f, const char *p, int len)
 981 {
 982
 983   write_float (f, p, len);
 984 }
 985
 986
 987 void
 988 write_es (fnode *f, const char *p, int len)
 989 {
 990
 991   write_float (f, p, len);
 992 }
 993
 994
 995 /* Take care of the X/TR descriptor.  */
 996
 997 void
 998 write_x (fnode * f)
 999 {
1000   char *p;
1001
1002   p = write_block (f->u.n);
1003   if (p == NULL)
1004     return;
1005
1006   memset (p, ' ', f->u.n);
1007 }
1008
1009
1010 /* List-directed writing.  */
1011
1012
1013 /* Write a single character to the output.  Returns nonzero if
1014    something goes wrong.  */
1015
1016 static int
1017 write_char (char c)
1018 {
1019   char *p;
1020
1021   p = write_block (1);
1022   if (p == NULL)
1023     return 1;
1024
1025   *p = c;
1026
1027   return 0;
1028 }
1029
1030
1031 /* Write a list-directed logical value.  */
1032
1033 static void
1034 write_logical (const char *source, int length)
1035 {
1036   write_char (extract_int (source, length) ? 'T' : 'F');
1037 }
1038
1039
1040 /* Write a list-directed integer value.  */
1041
1042 static void
1043 write_integer (const char *source, int length)
1044 {
1045   char *p;
1046   const char *q;
1047   int digits;
1048   int width;
1049
1050   q = itoa (extract_int (source, length));
1051
1052   switch (length)
1053     {
1054     case 1:
1055       width = 4;
1056       break;
1057
1058     case 2:
1059       width = 6;
1060       break;
1061
1062     case 4:
1063       width = 11;
1064       break;
1065
1066     case 8:
1067       width = 20;
1068       break;
1069
1070     default:
1071       width = 0;
1072       break;
1073     }
1074
1075   digits = strlen (q);
1076
1077   if(width < digits )
1078     width = digits ;
1079   p = write_block (width) ;
1080
1081   memset(p ,' ', width - digits) ;
1082   memcpy (p + width - digits, q, digits);
1083 }
1084
1085
1086 /* Write a list-directed string.  We have to worry about delimiting
1087    the strings if the file has been opened in that mode.  */
1088
1089 static void
1090 write_character (const char *source, int length)
1091 {
1092   int i, extra;
1093   char *p, d;
1094
1095   switch (current_unit->flags.delim)
1096     {
1097     case DELIM_APOSTROPHE:
1098       d = '\'';
1099       break;
1100     case DELIM_QUOTE:
1101       d = '"';
1102       break;
1103     default:
1104       d = ' ';
1105       break;
1106     }
1107
1108   if (d == ' ')
1109     extra = 0;
1110   else
1111     {
1112       extra = 2;
1113
1114       for (i = 0; i < length; i++)
1115         if (source[i] == d)
1116           extra++;
1117     }
1118
1119   p = write_block (length + extra);
1120   if (p == NULL)
1121     return;
1122
1123   if (d == ' ')
1124     memcpy (p, source, length);
1125   else
1126     {
1127       *p++ = d;
1128
1129       for (i = 0; i < length; i++)
1130         {
1131           *p++ = source[i];
1132           if (source[i] == d)
1133             *p++ = d;
1134         }
1135
1136       *p = d;
1137     }
1138 }
1139
1140
1141 /* Output a real number with default format.
1142    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1143
1144 static void
1145 write_real (const char *source, int length)
1146 {
1147   fnode f ;
1148   int org_scale = g.scale_factor;
1149   f.format = FMT_G;
1150   g.scale_factor = 1;
1151   if (length < 8)
1152     {
1153       f.u.real.w = 14;
1154       f.u.real.d = 7;
1155       f.u.real.e = 2;
1156     }
1157   else
1158     {
1159       f.u.real.w = 23;
1160       f.u.real.d = 15;
1161       f.u.real.e = 3;
1162     }
1163   write_float (&f, source , length);
1164   g.scale_factor = org_scale;
1165 }
1166
1167
1168 static void
1169 write_complex (const char *source, int len)
1170 {
1171
1172   if (write_char ('('))
1173     return;
1174   write_real (source, len);
1175
1176   if (write_char (','))
1177     return;
1178   write_real (source + len, len);
1179
1180   write_char (')');
1181 }
1182
1183
1184 /* Write the separator between items.  */
1185
1186 static void
1187 write_separator (void)
1188 {
1189   char *p;
1190
1191   p = write_block (options.separator_len);
1192   if (p == NULL)
1193     return;
1194
1195   memcpy (p, options.separator, options.separator_len);
1196 }
1197
1198
1199 /* Write an item with list formatting.
1200    TODO: handle skipping to the next record correctly, particularly
1201    with strings.  */
1202
1203 void
1204 list_formatted_write (bt type, void *p, int len)
1205 {
1206   static int char_flag;
1207
1208   if (current_unit == NULL)
1209     return;
1210
1211   if (g.first_item)
1212     {
1213       g.first_item = 0;
1214       char_flag = 0;
1215       write_char (' ');
1216     }
1217   else
1218     {
1219       if (type != BT_CHARACTER || !char_flag ||
1220           current_unit->flags.delim != DELIM_NONE)
1221         write_separator ();
1222     }
1223
1224   switch (type)
1225     {
1226     case BT_INTEGER:
1227       write_integer (p, len);
1228       break;
1229     case BT_LOGICAL:
1230       write_logical (p, len);
1231       break;
1232     case BT_CHARACTER:
1233       write_character (p, len);
1234       break;
1235     case BT_REAL:
1236       write_real (p, len);
1237       break;
1238     case BT_COMPLEX:
1239       write_complex (p, len);
1240       break;
1241     default:
1242       internal_error ("list_formatted_write(): Bad type");
1243     }
1244
1245   char_flag = (type == BT_CHARACTER);
1246 }
1247
1248 void
1249 namelist_write (void)
1250 {
1251    namelist_info * t1, *t2;
1252    int len,num;
1253    void * p;
1254
1255    num = 0;
1256    write_character("&",1);
1257    write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1258    write_character("\n",1);
1259
1260    if (ionml != NULL)
1261      {
1262        t1 = ionml;
1263        while (t1 != NULL)
1264         {
1265           num ++;
1266           t2 = t1;
1267           t1 = t1->next;
1268           if (t2->var_name)
1269             {
1270               write_character(t2->var_name, strlen(t2->var_name));
1271               write_character("=",1);
1272             }
1273           len = t2->len;
1274           p = t2->mem_pos;
1275           switch (t2->type)
1276             {
1277             case BT_INTEGER:
1278               write_integer (p, len);
1279               break;
1280             case BT_LOGICAL:
1281               write_logical (p, len);
1282               break;
1283             case BT_CHARACTER:
1284               write_character (p, t2->string_length);
1285               break;
1286             case BT_REAL:
1287               write_real (p, len);
1288               break;
1289             case BT_COMPLEX:
1290               write_complex (p, len);
1291               break;
1292             default:
1293               internal_error ("Bad type for namelist write");
1294             }
1295          write_character(",",1);
1296          if (num > 5)
1297            {
1298               num = 0;
1299               write_character("\n",1);
1300            }
1301         }
1302      }
1303      write_character("/",1);
1304
1305 }