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       if (value != 0.0)
 379         e -= i;
 380       if (i < 0)
 381         {
 382           nbefore = 0;
 383           nzero = -i;
 384           nafter = d + i;
 385         }
 386       else if (i > 0)
 387         {
 388           nbefore = i;
 389           nzero = 0;
 390           nafter = (d - i) + 1;
 391         }
 392       else /* i == 0 */
 393         {
 394           nbefore = 0;
 395           nzero = 0;
 396           nafter = d;
 397         }
 398
 399       if (ft == FMT_E)
 400         expchar = 'E';
 401       else
 402         expchar = 'D';
 403       break;
 404
 405     case FMT_EN:
 406       /* The exponent must be a multiple of three, with 1-3 digits before
 407          the decimal point.  */
 408       e--;
 409       if (e >= 0)
 410         nbefore = e % 3;
 411       else
 412         {
 413           nbefore = (-e) % 3;
 414           if (nbefore != 0)
 415             nbefore = 3 - nbefore;
 416         }
 417       e -= nbefore;
 418       nbefore++;
 419       nzero = 0;
 420       nafter = d;
 421       expchar = 'E';
 422       break;
 423
 424     case FMT_ES:
 425       e--;
 426       nbefore = 1;
 427       nzero = 0;
 428       nafter = d;
 429       expchar = 'E';
 430       break;
 431
 432     default:
 433       /* Should never happen.  */
 434       internal_error ("Unexpected format token");
 435     }
 436
 437   /* Round the value.  */
 438   if (nbefore + nafter == 0)
 439     ndigits = 0;
 440   else if (nbefore + nafter < ndigits)
 441     {
 442       ndigits = nbefore + nafter;
 443       i = ndigits;
 444       if (digits[i] >= '5')
 445         {
 446           /* Propagate the carry.  */
 447           for (i--; i >= 0; i--)
 448             {
 449               if (digits[i] != '9')
 450                 {
 451                   digits[i]++;
 452                   break;
 453                 }
 454               digits[i] = '0';
 455             }
 456
 457           if (i < 0)
 458             {
 459               /* The carry overflowed.  Fortunately we have some spare space
 460                  at the start of the buffer.  We may discard some digits, but
 461                  this is ok because we already know they are zero.  */
 462               digits--;
 463               digits[0] = '1';
 464               if (ft == FMT_F)
 465                 {
 466                   if (nzero > 0)
 467                     {
 468                       nzero--;
 469                       nafter++;
 470                     }
 471                   else
 472                     nbefore++;
 473                 }
 474               else if (ft == FMT_EN)
 475                 {
 476                   nbefore++;
 477                   if (nbefore == 4)
 478                     {
 479                       nbefore = 1;
 480                       e += 3;
 481                     }
 482                 }
 483               else
 484                 e++;
 485             }
 486         }
 487     }
 488
 489   /* Calculate the format of the exponent field.  */
 490   if (expchar)
 491     {
 492       edigits = 1;
 493       for (i = abs (e); i >= 10; i /= 10)
 494         edigits++;
 495
 496       if (f->u.real.e < 0)
 497         {
 498           /* Width not specified.  Must be no more than 3 digits.  */
 499           if (e > 999 || e < -999)
 500             edigits = -1;
 501           else
 502             {
 503               edigits = 4;
 504               if (e > 99 || e < -99)
 505                 expchar = ' ';
 506             }
 507         }
 508       else
 509         {
 510           /* Exponent width specified, check it is wide enough.  */
 511           if (edigits > f->u.real.e)
 512             edigits = -1;
 513           else
 514             edigits = f->u.real.e + 2;
 515         }
 516     }
 517   else
 518     edigits = 0;
 519
 520   /* Pick a field size if none was specified.  */
 521   if (w <= 0)
 522     w = nbefore + nzero + nafter + 2;
 523
 524   /* Create the ouput buffer.  */
 525   out = write_block (w);
 526   if (out == NULL)
 527     return;
 528
 529   /* Zero values always output as positive, even if the value was negative
 530      before rounding.  */
 531   for (i = 0; i < ndigits; i++)
 532     {
 533       if (digits[i] != '0')
 534         break;
 535     }
 536   if (i == ndigits)
 537     sign = calculate_sign (0);
 538
 539   /* Work out how much padding is needed.  */
 540   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
 541   if (sign != SIGN_NONE)
 542     nblanks--;
 543
 544   /* Check the value fits in the specified field width.  */
 545   if (nblanks < 0 || edigits == -1)
 546     {
 547       star_fill (out, w);
 548       return;
 549     }
 550
 551   /* See if we have space for a zero before the decimal point.  */
 552   if (nbefore == 0 && nblanks > 0)
 553     {
 554       leadzero = 1;
 555       nblanks--;
 556     }
 557   else
 558     leadzero = 0;
 559
 560   /* Padd to full field width.  */
 561   if (nblanks > 0)
 562     {
 563       memset (out, ' ', nblanks);
 564       out += nblanks;
 565     }
 566
 567   /* Output the initial sign (if any).  */
 568   if (sign == SIGN_PLUS)
 569     *(out++) = '+';
 570   else if (sign == SIGN_MINUS)
 571     *(out++) = '-';
 572
 573   /* Output an optional leading zero.  */
 574   if (leadzero)
 575     *(out++) = '0';
 576
 577   /* Output the part before the decimal point, padding with zeros.  */
 578   if (nbefore > 0)
 579     {
 580       if (nbefore > ndigits)
 581         i = ndigits;
 582       else
 583         i = nbefore;
 584
 585       memcpy (out, digits, i);
 586       while (i < nbefore)
 587         out[i++] = '0';
 588
 589       digits += i;
 590       ndigits -= i;
 591       out += nbefore;
 592     }
 593   /* Output the decimal point.  */
 594   *(out++) = '.';
 595
 596   /* Output leading zeros after the decimal point.  */
 597   if (nzero > 0)
 598     {
 599       for (i = 0; i < nzero; i++)
 600         *(out++) = '0';
 601     }
 602
 603   /* Output digits after the decimal point, padding with zeros.  */
 604   if (nafter > 0)
 605     {
 606       if (nafter > ndigits)
 607         i = ndigits;
 608       else
 609         i = nafter;
 610
 611       memcpy (out, digits, i);
 612       while (i < nafter)
 613         out[i++] = '0';
 614
 615       digits += i;
 616       ndigits -= i;
 617       out += nafter;
 618     }
 619
 620   /* Output the exponent.  */
 621   if (expchar)
 622     {
 623       if (expchar != ' ')
 624         {
 625           *(out++) = expchar;
 626           edigits--;
 627         }
 628 #if HAVE_SNPRINTF
 629       snprintf (buffer, 32, "%+0*d", edigits, e);
 630 #else
 631       sprintf (buffer, "%+0*d", edigits, e);
 632 #endif
 633       memcpy (out, buffer, edigits);
 634     }
 635 }
 636
 637
 638 void
 639 write_l (fnode * f, char *source, int len)
 640 {
 641   char *p;
 642   int64_t n;
 643
 644   p = write_block (f->u.w);
 645   if (p == NULL)
 646     return;
 647
 648   memset (p, ' ', f->u.w - 1);
 649   n = extract_int (source, len);
 650   p[f->u.w - 1] = (n) ? 'T' : 'F';
 651 }
 652
 653 /* Output a real number according to its format.  */
 654
 655 static void
 656 write_float (fnode *f, const char *source, int len)
 657 {
 658   double n;
 659   int nb =0, res;
 660   char * p, fin;
 661   fnode *f2 = NULL;
 662
 663   n = extract_real (source, len);
 664
 665   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 666     {
 667       res = isfinite (n);
 668       if (res == 0)
 669         {
 670           nb =  f->u.real.w;
 671           p = write_block (nb);
 672           if (nb < 3)
 673             {
 674               memset (p, '*',nb);
 675               return;
 676             }
 677
 678           memset(p, ' ', nb);
 679           res = !isnan (n);
 680           if (res != 0)
 681             {
 682               if (signbit(n))
 683                 fin = '-';
 684               else
 685                 fin = '+';
 686
 687               if (nb > 7)
 688                 memcpy(p + nb - 8, "Infinity", 8);
 689               else
 690                 memcpy(p + nb - 3, "Inf", 3);
 691               if (nb < 8 && nb > 3)
 692                 p[nb - 4] = fin;
 693               else if (nb > 8)
 694                 p[nb - 9] = fin;
 695             }
 696           else
 697             memcpy(p + nb - 3, "NaN", 3);
 698           return;
 699         }
 700     }
 701
 702   if (f->format != FMT_G)
 703     {
 704       output_float (f, n, len);
 705     }
 706   else
 707     {
 708       f2 = calculate_G_format(f, n, len, &nb);
 709       output_float (f2, n, len);
 710       if (f2 != NULL)
 711         free_mem(f2);
 712
 713       if (nb > 0)
 714         {
 715           p = write_block (nb);
 716           memset (p, ' ', nb);
 717         }
 718     }
 719 }
 720
 721
 722 static void
 723 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
 724 {
 725   uint32_t ns =0;
 726   uint64_t n = 0;
 727   int w, m, digits, nzero, nblank;
 728   char *p, *q;
 729
 730   w = f->u.integer.w;
 731   m = f->u.integer.m;
 732
 733   n = extract_int (source, len);
 734
 735   /* Special case:  */
 736
 737   if (m == 0 && n == 0)
 738     {
 739       if (w == 0)
 740         w = 1;
 741
 742       p = write_block (w);
 743       if (p == NULL)
 744         return;
 745
 746       memset (p, ' ', w);
 747       goto done;
 748     }
 749
 750
 751   if (len < 8)
 752      {
 753        ns = n;
 754        q = conv (ns);
 755      }
 756   else
 757       q = conv (n);
 758
 759   digits = strlen (q);
 760
 761   /* Select a width if none was specified.  The idea here is to always
 762      print something.  */
 763
 764   if (w == 0)
 765     w = ((digits < m) ? m : digits);
 766
 767   p = write_block (w);
 768   if (p == NULL)
 769     return;
 770
 771   nzero = 0;
 772   if (digits < m)
 773     nzero = m - digits;
 774
 775   /* See if things will work.  */
 776
 777   nblank = w - (nzero + digits);
 778
 779   if (nblank < 0)
 780     {
 781       star_fill (p, w);
 782       goto done;
 783     }
 784
 785   memset (p, ' ', nblank);
 786   p += nblank;
 787
 788   memset (p, '0', nzero);
 789   p += nzero;
 790
 791   memcpy (p, q, digits);
 792
 793  done:
 794   return;
 795 }
 796
 797 static void
 798 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
 799 {
 800   int64_t n = 0;
 801   int w, m, digits, nsign, nzero, nblank;
 802   char *p, *q;
 803   sign_t sign;
 804
 805   w = f->u.integer.w;
 806   m = f->u.integer.m;
 807
 808   n = extract_int (source, len);
 809
 810   /* Special case:  */
 811
 812   if (m == 0 && n == 0)
 813     {
 814       if (w == 0)
 815         w = 1;
 816
 817       p = write_block (w);
 818       if (p == NULL)
 819         return;
 820
 821       memset (p, ' ', w);
 822       goto done;
 823     }
 824
 825   sign = calculate_sign (n < 0);
 826   if (n < 0)
 827     n = -n;
 828
 829   nsign = sign == SIGN_NONE ? 0 : 1;
 830   q = conv (n);
 831
 832   digits = strlen (q);
 833
 834   /* Select a width if none was specified.  The idea here is to always
 835      print something.  */
 836
 837   if (w == 0)
 838     w = ((digits < m) ? m : digits) + nsign;
 839
 840   p = write_block (w);
 841   if (p == NULL)
 842     return;
 843
 844   nzero = 0;
 845   if (digits < m)
 846     nzero = m - digits;
 847
 848   /* See if things will work.  */
 849
 850   nblank = w - (nsign + nzero + digits);
 851
 852   if (nblank < 0)
 853     {
 854       star_fill (p, w);
 855       goto done;
 856     }
 857
 858   memset (p, ' ', nblank);
 859   p += nblank;
 860
 861   switch (sign)
 862     {
 863     case SIGN_PLUS:
 864       *p++ = '+';
 865       break;
 866     case SIGN_MINUS:
 867       *p++ = '-';
 868       break;
 869     case SIGN_NONE:
 870       break;
 871     }
 872
 873   memset (p, '0', nzero);
 874   p += nzero;
 875
 876   memcpy (p, q, digits);
 877
 878  done:
 879   return;
 880 }
 881
 882
 883 /* Convert unsigned octal to ascii.  */
 884
 885 static char *
 886 otoa (uint64_t n)
 887 {
 888   char *p;
 889
 890   if (n == 0)
 891     {
 892       scratch[0] = '0';
 893       scratch[1] = '\0';
 894       return scratch;
 895     }
 896
 897   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 898   *p-- = '\0';
 899
 900   while (n != 0)
 901     {
 902       *p = '0' + (n & 7);
 903       p -- ;
 904       n >>= 3;
 905     }
 906
 907   return ++p;
 908 }
 909
 910
 911 /* Convert unsigned binary to ascii.  */
 912
 913 static char *
 914 btoa (uint64_t n)
 915 {
 916   char *p;
 917
 918   if (n == 0)
 919     {
 920       scratch[0] = '0';
 921       scratch[1] = '\0';
 922       return scratch;
 923     }
 924
 925   p = scratch + sizeof (SCRATCH_SIZE) - 1;
 926   *p-- = '\0';
 927
 928   while (n != 0)
 929     {
 930       *p-- = '0' + (n & 1);
 931       n >>= 1;
 932     }
 933
 934   return ++p;
 935 }
 936
 937
 938 void
 939 write_i (fnode * f, const char *p, int len)
 940 {
 941   write_decimal (f, p, len, (void *) gfc_itoa);
 942 }
 943
 944
 945 void
 946 write_b (fnode * f, const char *p, int len)
 947 {
 948   write_int (f, p, len, btoa);
 949 }
 950
 951
 952 void
 953 write_o (fnode * f, const char *p, int len)
 954 {
 955   write_int (f, p, len, otoa);
 956 }
 957
 958 void
 959 write_z (fnode * f, const char *p, int len)
 960 {
 961   write_int (f, p, len, xtoa);
 962 }
 963
 964
 965 void
 966 write_d (fnode *f, const char *p, int len)
 967 {
 968   write_float (f, p, len);
 969 }
 970
 971
 972 void
 973 write_e (fnode *f, const char *p, int len)
 974 {
 975   write_float (f, p, len);
 976 }
 977
 978
 979 void
 980 write_f (fnode *f, const char *p, int len)
 981 {
 982   write_float (f, p, len);
 983 }
 984
 985
 986 void
 987 write_en (fnode *f, const char *p, int len)
 988 {
 989   write_float (f, p, len);
 990 }
 991
 992
 993 void
 994 write_es (fnode *f, const char *p, int len)
 995 {
 996   write_float (f, p, len);
 997 }
 998
 999
1000 /* Take care of the X/TR descriptor.  */
1001
1002 void
1003 write_x (fnode * f)
1004 {
1005   char *p;
1006
1007   p = write_block (f->u.n);
1008   if (p == NULL)
1009     return;
1010
1011   memset (p, ' ', f->u.n);
1012 }
1013
1014
1015 /* List-directed writing.  */
1016
1017
1018 /* Write a single character to the output.  Returns nonzero if
1019    something goes wrong.  */
1020
1021 static int
1022 write_char (char c)
1023 {
1024   char *p;
1025
1026   p = write_block (1);
1027   if (p == NULL)
1028     return 1;
1029
1030   *p = c;
1031
1032   return 0;
1033 }
1034
1035
1036 /* Write a list-directed logical value.  */
1037
1038 static void
1039 write_logical (const char *source, int length)
1040 {
1041   write_char (extract_int (source, length) ? 'T' : 'F');
1042 }
1043
1044
1045 /* Write a list-directed integer value.  */
1046
1047 static void
1048 write_integer (const char *source, int length)
1049 {
1050   char *p;
1051   const char *q;
1052   int digits;
1053   int width;
1054
1055   q = gfc_itoa (extract_int (source, length));
1056
1057   switch (length)
1058     {
1059     case 1:
1060       width = 4;
1061       break;
1062
1063     case 2:
1064       width = 6;
1065       break;
1066
1067     case 4:
1068       width = 11;
1069       break;
1070
1071     case 8:
1072       width = 20;
1073       break;
1074
1075     default:
1076       width = 0;
1077       break;
1078     }
1079
1080   digits = strlen (q);
1081
1082   if(width < digits )
1083     width = digits ;
1084   p = write_block (width) ;
1085
1086   memset(p ,' ', width - digits) ;
1087   memcpy (p + width - digits, q, digits);
1088 }
1089
1090
1091 /* Write a list-directed string.  We have to worry about delimiting
1092    the strings if the file has been opened in that mode.  */
1093
1094 static void
1095 write_character (const char *source, int length)
1096 {
1097   int i, extra;
1098   char *p, d;
1099
1100   switch (current_unit->flags.delim)
1101     {
1102     case DELIM_APOSTROPHE:
1103       d = '\'';
1104       break;
1105     case DELIM_QUOTE:
1106       d = '"';
1107       break;
1108     default:
1109       d = ' ';
1110       break;
1111     }
1112
1113   if (d == ' ')
1114     extra = 0;
1115   else
1116     {
1117       extra = 2;
1118
1119       for (i = 0; i < length; i++)
1120         if (source[i] == d)
1121           extra++;
1122     }
1123
1124   p = write_block (length + extra);
1125   if (p == NULL)
1126     return;
1127
1128   if (d == ' ')
1129     memcpy (p, source, length);
1130   else
1131     {
1132       *p++ = d;
1133
1134       for (i = 0; i < length; i++)
1135         {
1136           *p++ = source[i];
1137           if (source[i] == d)
1138             *p++ = d;
1139         }
1140
1141       *p = d;
1142     }
1143 }
1144
1145
1146 /* Output a real number with default format.
1147    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1148
1149 static void
1150 write_real (const char *source, int length)
1151 {
1152   fnode f ;
1153   int org_scale = g.scale_factor;
1154   f.format = FMT_G;
1155   g.scale_factor = 1;
1156   if (length < 8)
1157     {
1158       f.u.real.w = 14;
1159       f.u.real.d = 7;
1160       f.u.real.e = 2;
1161     }
1162   else
1163     {
1164       f.u.real.w = 23;
1165       f.u.real.d = 15;
1166       f.u.real.e = 3;
1167     }
1168   write_float (&f, source , length);
1169   g.scale_factor = org_scale;
1170 }
1171
1172
1173 static void
1174 write_complex (const char *source, int len)
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 }