libf2c/libI77/wref.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #ifndef VAX
   4 #include <ctype.h>
   5 #endif
   6
   7 #undef abs
   8 #undef min
   9 #undef max
  10 #include <stdlib.h>
  11 #include <string.h>
  12
  13 #include "fmt.h"
  14 #include "fp.h"
  15
  16 int
  17 wrt_E (ufloat * p, int w, int d, int e, ftnlen len)
  18 {
  19   char buf[FMAX + EXPMAXDIGS + 4], *s, *se;
  20   int d1, delta, e1, i, sign, signspace;
  21   double dd;
  22 #ifdef WANT_LEAD_0
  23   int insert0 = 0;
  24 #endif
  25 #ifndef VAX
  26   int e0 = e;
  27 #endif
  28
  29   if (e <= 0)
  30     e = 2;
  31   if (f__scale)
  32     {
  33       if (f__scale >= d + 2 || f__scale <= -d)
  34         goto nogood;
  35     }
  36   if (f__scale <= 0)
  37     --d;
  38   if (len == sizeof (real))
  39     dd = p->pf;
  40   else
  41     dd = p->pd;
  42   if (dd < 0.)
  43     {
  44       signspace = sign = 1;
  45       dd = -dd;
  46     }
  47   else
  48     {
  49       sign = 0;
  50       signspace = (int) f__cplus;
  51 #ifndef VAX
  52       if (!dd)
  53         dd = 0.;                /* avoid -0 */
  54 #endif
  55     }
  56   delta = w - (2                /* for the . and the d adjustment above */
  57                + 2 /* for the E+ */  + signspace + d + e);
  58 #ifdef WANT_LEAD_0
  59   if (f__scale <= 0 && delta > 0)
  60     {
  61       delta--;
  62       insert0 = 1;
  63     }
  64   else
  65 #endif
  66   if (delta < 0)
  67     {
  68     nogood:
  69       while (--w >= 0)
  70         PUT ('*');
  71       return (0);
  72     }
  73   if (f__scale < 0)
  74     d += f__scale;
  75   if (d > FMAX)
  76     {
  77       d1 = d - FMAX;
  78       d = FMAX;
  79     }
  80   else
  81     d1 = 0;
  82   sprintf (buf, "%#.*E", d, dd);
  83 #ifndef VAX
  84   /* check for NaN, Infinity */
  85   if (!isdigit ((unsigned char) buf[0]))
  86     {
  87       switch (buf[0])
  88         {
  89         case 'n':
  90         case 'N':
  91           signspace = 0;        /* no sign for NaNs */
  92         }
  93       delta = w - strlen (buf) - signspace;
  94       if (delta < 0)
  95         goto nogood;
  96       while (--delta >= 0)
  97         PUT (' ');
  98       if (signspace)
  99         PUT (sign ? '-' : '+');
 100       for (s = buf; *s; s++)
 101         PUT (*s);
 102       return 0;
 103     }
 104 #endif
 105   se = buf + d + 3;
 106 #ifdef GOOD_SPRINTF_EXPONENT    /* When possible, exponent has 2 digits. */
 107   if (f__scale != 1 && dd)
 108     sprintf (se, "%+.2d", atoi (se) + 1 - f__scale);
 109 #else
 110   if (dd)
 111     sprintf (se, "%+.2d", atoi (se) + 1 - f__scale);
 112   else
 113     strcpy (se, "+00");
 114 #endif
 115   s = ++se;
 116   if (e < 2)
 117     {
 118       if (*s != '0')
 119         goto nogood;
 120     }
 121 #ifndef VAX
 122   /* accommodate 3 significant digits in exponent */
 123   if (s[2])
 124     {
 125 #ifdef Pedantic
 126       if (!e0 && !s[3])
 127         for (s -= 2, e1 = 2; s[0] = s[1]; s++);
 128
 129       /* Pedantic gives the behavior that Fortran 77 specifies,       */
 130       /* i.e., requires that E be specified for exponent fields       */
 131       /* of more than 3 digits.  With Pedantic undefined, we get      */
 132       /* the behavior that Cray displays -- you get a bigger          */
 133       /* exponent field if it fits.   */
 134 #else
 135       if (!e0)
 136         {
 137           for (s -= 2, e1 = 2; (s[0] = s[1]); s++)
 138 #ifdef CRAY
 139             delta--;
 140           if ((delta += 4) < 0)
 141             goto nogood
 142 #endif
 143               ;
 144         }
 145 #endif
 146       else if (e0 >= 0)
 147         goto shift;
 148       else
 149         e1 = e;
 150     }
 151   else
 152   shift:
 153 #endif
 154     for (s += 2, e1 = 2; *s; ++e1, ++s)
 155       if (e1 >= e)
 156         goto nogood;
 157   while (--delta >= 0)
 158     PUT (' ');
 159   if (signspace)
 160     PUT (sign ? '-' : '+');
 161   s = buf;
 162   i = f__scale;
 163   if (f__scale <= 0)
 164     {
 165 #ifdef WANT_LEAD_0
 166       if (insert0)
 167         PUT ('0');
 168 #endif
 169       PUT ('.');
 170       for (; i < 0; ++i)
 171         PUT ('0');
 172       PUT (*s);
 173       s += 2;
 174     }
 175   else if (f__scale > 1)
 176     {
 177       PUT (*s);
 178       s += 2;
 179       while (--i > 0)
 180         PUT (*s++);
 181       PUT ('.');
 182     }
 183   if (d1)
 184     {
 185       se -= 2;
 186       while (s < se)
 187         PUT (*s++);
 188       se += 2;
 189       do
 190         PUT ('0');
 191       while (--d1 > 0);
 192     }
 193   while (s < se)
 194     PUT (*s++);
 195   if (e < 2)
 196     PUT (s[1]);
 197   else
 198     {
 199       while (++e1 <= e)
 200         PUT ('0');
 201       while (*s)
 202         PUT (*s++);
 203     }
 204   return 0;
 205 }
 206
 207 int
 208 wrt_F (ufloat * p, int w, int d, ftnlen len)
 209 {
 210   int d1, sign, n;
 211   double x;
 212   char *b, buf[MAXINTDIGS + MAXFRACDIGS + 4], *s;
 213
 214   x = (len == sizeof (real) ? p->pf : p->pd);
 215   if (d < MAXFRACDIGS)
 216     d1 = 0;
 217   else
 218     {
 219       d1 = d - MAXFRACDIGS;
 220       d = MAXFRACDIGS;
 221     }
 222   if (x < 0.)
 223     {
 224       x = -x;
 225       sign = 1;
 226     }
 227   else
 228     {
 229       sign = 0;
 230 #ifndef VAX
 231       if (!x)
 232         x = 0.;
 233 #endif
 234     }
 235
 236   if ((n = f__scale))
 237     {
 238       if (n > 0)
 239         do
 240           x *= 10.;
 241         while (--n > 0);
 242       else
 243         do
 244           x *= 0.1;
 245         while (++n < 0);
 246     }
 247
 248 #ifdef USE_STRLEN
 249   sprintf (b = buf, "%#.*f", d, x);
 250   n = strlen (b) + d1;
 251 #else
 252   n = sprintf (b = buf, "%#.*f", d, x) + d1;
 253 #endif
 254
 255 #ifndef WANT_LEAD_0
 256   if (buf[0] == '0' && d)
 257     {
 258       ++b;
 259       --n;
 260     }
 261 #endif
 262   if (sign)
 263     {
 264       /* check for all zeros */
 265       for (s = b;;)
 266         {
 267           while (*s == '0')
 268             s++;
 269           switch (*s)
 270             {
 271             case '.':
 272               s++;
 273               continue;
 274             case 0:
 275               sign = 0;
 276             }
 277           break;
 278         }
 279     }
 280   if (sign || f__cplus)
 281     ++n;
 282   if (n > w)
 283     {
 284 #ifdef WANT_LEAD_0
 285       if (buf[0] == '0' && --n == w)
 286         ++b;
 287       else
 288 #endif
 289         {
 290           while (--w >= 0)
 291             PUT ('*');
 292           return 0;
 293         }
 294     }
 295   for (w -= n; --w >= 0;)
 296     PUT (' ');
 297   if (sign)
 298     PUT ('-');
 299   else if (f__cplus)
 300     PUT ('+');
 301   while ((n = *b++))
 302     PUT (n);
 303   while (--d1 >= 0)
 304     PUT ('0');
 305   return 0;
 306 }