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 #if HAVE_SNPRINTF
 619       snprintf (buffer, 32, "%+0*d", edigits, e);
 620 #else
 621       sprintf (buffer, "%+0*d", edigits, e);
 622 #endif
 623       memcpy (out, buffer, edigits);
 624     }
 625 }
 626
 627
 628 void
 629 write_l (fnode * f, char *source, int len)
 630 {
 631   char *p;
 632   int64_t n;
 633
 634   p = write_block (f->u.w);
 635   if (p == NULL)
 636     return;
 637
 638   memset (p, ' ', f->u.w - 1);
 639   n = extract_int (source, len);
 640   p[f->u.w - 1] = (n) ? 'T' : 'F';
 641 }
 642
 643 /* Output a real number according to its format.  */
 644
 645 static void
 646 write_float (fnode *f, const char *source, int len)
 647 {
 648   double n;
 649   int nb =0, res;
 650   char * p, fin;
 651   fnode *f2 = NULL;
 652
 653   n = extract_real (source, len);
 654
 655   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 656     {
 657       res = isfinite (n);
 658       if (res == 0)
 659         {
 660           nb =  f->u.real.w;
 661           p = write_block (nb);
 662           if (nb < 3)
 663             {
 664               memset (p, '*',nb);
 665               return;
 666             }
 667
 668           memset(p, ' ', nb);
 669           res = !isnan (n);
 670           if (res != 0)
 671             {
 672               if (signbit(n))
 673                 fin = '-';
 674               else
 675                 fin = '+';
 676
 677               if (nb > 7)
 678                 memcpy(p + nb - 8, "Infinity", 8);
 679               else
 680                 memcpy(p + nb - 3, "Inf", 3);
 681               if (nb < 8 && nb > 3)
 682                 p[nb - 4] = fin;
 683               else if (nb > 8)
 684                 p[nb - 9] = fin;
 685             }
 686           else
 687             memcpy(p + nb - 3, "NaN", 3);
 688           return;
 689         }
 690     }
 691
 692   if (f->format != FMT_G)
 693     {
 694       output_float (f, n, len);
 695     }
 696   else
 697     {
 698       f2 = calculate_G_format(f, n, len, &nb);
 699       output_float (f2, n, len);
 700       if (f2 != NULL)
 701         free_mem(f2);
 702
 703       if (nb > 0)
 704         {
 705           p = write_block (nb);
 706           memset (p, ' ', nb);
 707         }
 708     }
 709 }
 710
 711
 712 static void
 713 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 714 {
 715   uint32_t ns =0;
 716   uint64_t n = 0;
 717   int w, m, digits, nzero, nblank;
 718   char *p, *q;
 719
 720   w = f->u.integer.w;
 721   m = f->u.integer.m;
 722
 723   n = extract_int (source, len);
 724
 725   /* Special case:  */
 726
 727   if (m == 0 && n == 0)
 728     {
 729       if (w == 0)
 730         w = 1;
 731
 732       p = write_block (w);
 733       if (p == NULL)
 734         return;
 735
 736       memset (p, ' ', w);
 737       goto done;
 738     }
 739
 740
 741   if (len < 8)
 742      {
 743        ns = n;
 744        q = conv (ns);
 745      }
 746   else
 747       q = conv (n);
 748
 749   digits = strlen (q);
 750
 751   /* Select a width if none was specified.  The idea here is to always
 752      print something.  */
 753
 754   if (w == 0)
 755     w = ((digits < m) ? m : digits);
 756
 757   p = write_block (w);
 758   if (p == NULL)
 759     return;
 760
 761   nzero = 0;
 762   if (digits < m)
 763     nzero = m - digits;
 764
 765   /* See if things will work.  */
 766
 767   nblank = w - (nzero + digits);
 768
 769   if (nblank < 0)
 770     {
 771       star_fill (p, w);
 772       goto done;
 773     }
 774
 775   memset (p, ' ', nblank);
 776   p += nblank;
 777
 778   memset (p, '0', nzero);
 779   p += nzero;
 780
 781   memcpy (p, q, digits);
 782
 783 done:
 784   return;
 785 }
 786
 787 static void
 788 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 789 {
 790   int64_t n = 0;
 791   int w, m, digits, nsign, nzero, nblank;
 792   char *p, *q;
 793   sign_t sign;
 794
 795   w = f->u.integer.w;
 796   m = f->u.integer.m;
 797
 798   n = extract_int (source, len);
 799
 800   /* Special case:  */
 801
 802   if (m == 0 && n == 0)
 803     {
 804       if (w == 0)
 805         w = 1;
 806
 807       p = write_block (w);
 808       if (p == NULL)
 809         return;
 810
 811       memset (p, ' ', w);
 812       goto done;
 813     }
 814
 815   sign = calculate_sign (n < 0);
 816   if (n < 0)
 817     n = -n;
 818
 819   nsign = sign == SIGN_NONE ? 0 : 1;
 820   q = conv (n);
 821
 822   digits = strlen (q);
 823
 824   /* Select a width if none was specified.  The idea here is to always
 825      print something.  */
 826
 827   if (w == 0)
 828     w = ((digits < m) ? m : digits) + nsign;
 829
 830   p = write_block (w);
 831   if (p == NULL)
 832     return;
 833
 834   nzero = 0;
 835   if (digits < m)
 836     nzero = m - digits;
 837
 838   /* See if things will work.  */
 839
 840   nblank = w - (nsign + nzero + digits);
 841
 842   if (nblank < 0)
 843     {
 844       star_fill (p, w);
 845       goto done;
 846     }
 847
 848   memset (p, ' ', nblank);
 849   p += nblank;
 850
 851   switch (sign)
 852     {
 853     case SIGN_PLUS:
 854       *p++ = '+';
 855       break;
 856     case SIGN_MINUS:
 857       *p++ = '-';
 858       break;
 859     case SIGN_NONE:
 860       break;
 861     }
 862
 863   memset (p, '0', nzero);
 864   p += nzero;
 865
 866   memcpy (p, q, digits);
 867
 868 done:
 869   return;
 870 }
 871
 872
 873 /* Convert unsigned octal to ascii.  */
 874
 875 static char *
 876 otoa (uint64_t n)
 877 {
 878   char *p;
 879
 880   if (n == 0)
 881     {
 882       scratch[0] = '0';
 883       scratch[1] = '\0';
 884       return scratch;
 885     }
 886
 887   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 888   *p-- = '\0';
 889
 890   while (n != 0)
 891     {
 892       *p = '0' + (n & 7);
 893       p -- ;
 894       n >>= 3;
 895     }
 896
 897   return ++p;
 898 }
 899
 900
 901 /* Convert unsigned binary to ascii.  */
 902
 903 static char *
 904 btoa (uint64_t n)
 905 {
 906   char *p;
 907
 908   if (n == 0)
 909     {
 910       scratch[0] = '0';
 911       scratch[1] = '\0';
 912       return scratch;
 913     }
 914
 915   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 916   *p-- = '\0';
 917
 918   while (n != 0)
 919     {
 920       *p-- = '0' + (n & 1);
 921       n >>= 1;
 922     }
 923
 924   return ++p;
 925 }
 926
 927
 928 void
 929 write_i (fnode * f, const char *p, int len)
 930 {
 931
 932   write_decimal (f, p, len, (void *) itoa);
 933 }
 934
 935
 936 void
 937 write_b (fnode * f, const char *p, int len)
 938 {
 939
 940   write_int (f, p, len, btoa);
 941 }
 942
 943
 944 void
 945 write_o (fnode * f, const char *p, int len)
 946 {
 947
 948   write_int (f, p, len, otoa);
 949 }
 950
 951 void
 952 write_z (fnode * f, const char *p, int len)
 953 {
 954
 955   write_int (f, p, len, xtoa);
 956 }
 957
 958
 959 void
 960 write_d (fnode *f, const char *p, int len)
 961 {
 962
 963   write_float (f, p, len);
 964 }
 965
 966
 967 void
 968 write_e (fnode *f, const char *p, int len)
 969 {
 970
 971   write_float (f, p, len);
 972 }
 973
 974
 975 void
 976 write_f (fnode *f, const char *p, int len)
 977 {
 978
 979   write_float (f, p, len);
 980 }
 981
 982
 983 void
 984 write_en (fnode *f, const char *p, int len)
 985 {
 986
 987   write_float (f, p, len);
 988 }
 989
 990
 991 void
 992 write_es (fnode *f, const char *p, int len)
 993 {
 994
 995   write_float (f, p, len);
 996 }
 997
 998
 999 /* Take care of the X/TR descriptor.  */
1000
1001 void
1002 write_x (fnode * f)
1003 {
1004   char *p;
1005
1006   p = write_block (f->u.n);
1007   if (p == NULL)
1008     return;
1009
1010   memset (p, ' ', f->u.n);
1011 }
1012
1013
1014 /* List-directed writing.  */
1015
1016
1017 /* Write a single character to the output.  Returns nonzero if
1018    something goes wrong.  */
1019
1020 static int
1021 write_char (char c)
1022 {
1023   char *p;
1024
1025   p = write_block (1);
1026   if (p == NULL)
1027     return 1;
1028
1029   *p = c;
1030
1031   return 0;
1032 }
1033
1034
1035 /* Write a list-directed logical value.  */
1036
1037 static void
1038 write_logical (const char *source, int length)
1039 {
1040   write_char (extract_int (source, length) ? 'T' : 'F');
1041 }
1042
1043
1044 /* Write a list-directed integer value.  */
1045
1046 static void
1047 write_integer (const char *source, int length)
1048 {
1049   char *p;
1050   const char *q;
1051   int digits;
1052   int width;
1053
1054   q = itoa (extract_int (source, length));
1055
1056   switch (length)
1057     {
1058     case 1:
1059       width = 4;
1060       break;
1061
1062     case 2:
1063       width = 6;
1064       break;
1065
1066     case 4:
1067       width = 11;
1068       break;
1069
1070     case 8:
1071       width = 20;
1072       break;
1073
1074     default:
1075       width = 0;
1076       break;
1077     }
1078
1079   digits = strlen (q);
1080
1081   if(width < digits )
1082     width = digits ;
1083   p = write_block (width) ;
1084
1085   memset(p ,' ', width - digits) ;
1086   memcpy (p + width - digits, q, digits);
1087 }
1088
1089
1090 /* Write a list-directed string.  We have to worry about delimiting
1091    the strings if the file has been opened in that mode.  */
1092
1093 static void
1094 write_character (const char *source, int length)
1095 {
1096   int i, extra;
1097   char *p, d;
1098
1099   switch (current_unit->flags.delim)
1100     {
1101     case DELIM_APOSTROPHE:
1102       d = '\'';
1103       break;
1104     case DELIM_QUOTE:
1105       d = '"';
1106       break;
1107     default:
1108       d = ' ';
1109       break;
1110     }
1111
1112   if (d == ' ')
1113     extra = 0;
1114   else
1115     {
1116       extra = 2;
1117
1118       for (i = 0; i < length; i++)
1119         if (source[i] == d)
1120           extra++;
1121     }
1122
1123   p = write_block (length + extra);
1124   if (p == NULL)
1125     return;
1126
1127   if (d == ' ')
1128     memcpy (p, source, length);
1129   else
1130     {
1131       *p++ = d;
1132
1133       for (i = 0; i < length; i++)
1134         {
1135           *p++ = source[i];
1136           if (source[i] == d)
1137             *p++ = d;
1138         }
1139
1140       *p = d;
1141     }
1142 }
1143
1144
1145 /* Output a real number with default format.
1146    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1147
1148 static void
1149 write_real (const char *source, int length)
1150 {
1151   fnode f ;
1152   int org_scale = g.scale_factor;
1153   f.format = FMT_G;
1154   g.scale_factor = 1;
1155   if (length < 8)
1156     {
1157       f.u.real.w = 14;
1158       f.u.real.d = 7;
1159       f.u.real.e = 2;
1160     }
1161   else
1162     {
1163       f.u.real.w = 23;
1164       f.u.real.d = 15;
1165       f.u.real.e = 3;
1166     }
1167   write_float (&f, source , length);
1168   g.scale_factor = org_scale;
1169 }
1170
1171
1172 static void
1173 write_complex (const char *source, int len)
1174 {
1175
1176   if (write_char ('('))
1177     return;
1178   write_real (source, len);
1179
1180   if (write_char (','))
1181     return;
1182   write_real (source + len, len);
1183
1184   write_char (')');
1185 }
1186
1187
1188 /* Write the separator between items.  */
1189
1190 static void
1191 write_separator (void)
1192 {
1193   char *p;
1194
1195   p = write_block (options.separator_len);
1196   if (p == NULL)
1197     return;
1198
1199   memcpy (p, options.separator, options.separator_len);
1200 }
1201
1202
1203 /* Write an item with list formatting.
1204    TODO: handle skipping to the next record correctly, particularly
1205    with strings.  */
1206
1207 void
1208 list_formatted_write (bt type, void *p, int len)
1209 {
1210   static int char_flag;
1211
1212   if (current_unit == NULL)
1213     return;
1214
1215   if (g.first_item)
1216     {
1217       g.first_item = 0;
1218       char_flag = 0;
1219       write_char (' ');
1220     }
1221   else
1222     {
1223       if (type != BT_CHARACTER || !char_flag ||
1224           current_unit->flags.delim != DELIM_NONE)
1225         write_separator ();
1226     }
1227
1228   switch (type)
1229     {
1230     case BT_INTEGER:
1231       write_integer (p, len);
1232       break;
1233     case BT_LOGICAL:
1234       write_logical (p, len);
1235       break;
1236     case BT_CHARACTER:
1237       write_character (p, len);
1238       break;
1239     case BT_REAL:
1240       write_real (p, len);
1241       break;
1242     case BT_COMPLEX:
1243       write_complex (p, len);
1244       break;
1245     default:
1246       internal_error ("list_formatted_write(): Bad type");
1247     }
1248
1249   char_flag = (type == BT_CHARACTER);
1250 }
1251
1252 void
1253 namelist_write (void)
1254 {
1255   namelist_info * t1, *t2;
1256   int len,num;
1257   void * p;
1258
1259   num = 0;
1260   write_character("&",1);
1261   write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1262   write_character("\n",1);
1263
1264   if (ionml != NULL)
1265     {
1266       t1 = ionml;
1267       while (t1 != NULL)
1268         {
1269           num ++;
1270           t2 = t1;
1271           t1 = t1->next;
1272           if (t2->var_name)
1273             {
1274               write_character(t2->var_name, strlen(t2->var_name));
1275               write_character("=",1);
1276             }
1277           len = t2->len;
1278           p = t2->mem_pos;
1279           switch (t2->type)
1280             {
1281             case BT_INTEGER:
1282               write_integer (p, len);
1283               break;
1284             case BT_LOGICAL:
1285               write_logical (p, len);
1286               break;
1287             case BT_CHARACTER:
1288               write_character (p, t2->string_length);
1289               break;
1290             case BT_REAL:
1291               write_real (p, len);
1292               break;
1293             case BT_COMPLEX:
1294               write_complex (p, len);
1295               break;
1296             default:
1297               internal_error ("Bad type for namelist write");
1298             }
1299           write_character(",",1);
1300           if (num > 5)
1301             {
1302               num = 0;
1303               write_character("\n",1);
1304             }
1305         }
1306     }
1307   write_character("/",1);
1308 }