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