libf2c/libI77/wrtfmt.c

   1 #include "config.h"
   2 #include "f2c.h"
   3 #include "fio.h"
   4 #include "fmt.h"
   5
   6 extern icilist *f__svic;
   7 extern char *f__icptr;
   8
   9 static int
  10 mv_cur (void)                   /* shouldn't use fseek because it insists on calling fflush */
  11                 /* instead we know too much about stdio */
  12 {
  13   int cursor = f__cursor;
  14   f__cursor = 0;
  15   if (f__external == 0)
  16     {
  17       if (cursor < 0)
  18         {
  19           if (f__hiwater < f__recpos)
  20             f__hiwater = f__recpos;
  21           f__recpos += cursor;
  22           f__icptr += cursor;
  23           if (f__recpos < 0)
  24             err (f__elist->cierr, 110, "left off");
  25         }
  26       else if (cursor > 0)
  27         {
  28           if (f__recpos + cursor >= f__svic->icirlen)
  29             err (f__elist->cierr, 110, "recend");
  30           if (f__hiwater <= f__recpos)
  31             for (; cursor > 0; cursor--)
  32               (*f__putn) (' ');
  33           else if (f__hiwater <= f__recpos + cursor)
  34             {
  35               cursor -= f__hiwater - f__recpos;
  36               f__icptr += f__hiwater - f__recpos;
  37               f__recpos = f__hiwater;
  38               for (; cursor > 0; cursor--)
  39                 (*f__putn) (' ');
  40             }
  41           else
  42             {
  43               f__icptr += cursor;
  44               f__recpos += cursor;
  45             }
  46         }
  47       return (0);
  48     }
  49   if (cursor > 0)
  50     {
  51       if (f__hiwater <= f__recpos)
  52         for (; cursor > 0; cursor--)
  53           (*f__putn) (' ');
  54       else if (f__hiwater <= f__recpos + cursor)
  55         {
  56           cursor -= f__hiwater - f__recpos;
  57           f__recpos = f__hiwater;
  58           for (; cursor > 0; cursor--)
  59             (*f__putn) (' ');
  60         }
  61       else
  62         {
  63           f__recpos += cursor;
  64         }
  65     }
  66   else if (cursor < 0)
  67     {
  68       if (cursor + f__recpos < 0)
  69         err (f__elist->cierr, 110, "left off");
  70       if (f__hiwater < f__recpos)
  71         f__hiwater = f__recpos;
  72       f__recpos += cursor;
  73     }
  74   return (0);
  75 }
  76
  77 static int
  78 wrt_Z (Uint * n, int w, int minlen, ftnlen len)
  79 {
  80   register char *s, *se;
  81   register int i, w1;
  82   static int one = 1;
  83   static char hex[] = "0123456789ABCDEF";
  84   s = (char *) n;
  85   --len;
  86   if (*(char *) &one)
  87     {
  88       /* little endian */
  89       se = s;
  90       s += len;
  91       i = -1;
  92     }
  93   else
  94     {
  95       se = s + len;
  96       i = 1;
  97     }
  98   for (;; s += i)
  99     if (s == se || *s)
 100       break;
 101   w1 = (i * (se - s) << 1) + 1;
 102   if (*s & 0xf0)
 103     w1++;
 104   if (w1 > w)
 105     for (i = 0; i < w; i++)
 106       (*f__putn) ('*');
 107   else
 108     {
 109       if ((minlen -= w1) > 0)
 110         w1 += minlen;
 111       while (--w >= w1)
 112         (*f__putn) (' ');
 113       while (--minlen >= 0)
 114         (*f__putn) ('0');
 115       if (!(*s & 0xf0))
 116         {
 117           (*f__putn) (hex[*s & 0xf]);
 118           if (s == se)
 119             return 0;
 120           s += i;
 121         }
 122       for (;; s += i)
 123         {
 124           (*f__putn) (hex[*s >> 4 & 0xf]);
 125           (*f__putn) (hex[*s & 0xf]);
 126           if (s == se)
 127             break;
 128         }
 129     }
 130   return 0;
 131 }
 132
 133 static int
 134 wrt_I (Uint * n, int w, ftnlen len, register int base)
 135 {
 136   int ndigit, sign, spare, i;
 137   longint x;
 138   char *ans;
 139   if (len == sizeof (integer))
 140     x = n->il;
 141   else if (len == sizeof (char))
 142     x = n->ic;
 143 #ifdef Allow_TYQUAD
 144   else if (len == sizeof (longint))
 145     x = n->ili;
 146 #endif
 147   else
 148     x = n->is;
 149   ans = f__icvt (x, &ndigit, &sign, base);
 150   spare = w - ndigit;
 151   if (sign || f__cplus)
 152     spare--;
 153   if (spare < 0)
 154     for (i = 0; i < w; i++)
 155       (*f__putn) ('*');
 156   else
 157     {
 158       for (i = 0; i < spare; i++)
 159         (*f__putn) (' ');
 160       if (sign)
 161         (*f__putn) ('-');
 162       else if (f__cplus)
 163         (*f__putn) ('+');
 164       for (i = 0; i < ndigit; i++)
 165         (*f__putn) (*ans++);
 166     }
 167   return (0);
 168 }
 169 static int
 170 wrt_IM (Uint * n, int w, int m, ftnlen len, int base)
 171 {
 172   int ndigit, sign, spare, i, xsign;
 173   longint x;
 174   char *ans;
 175   if (sizeof (integer) == len)
 176     x = n->il;
 177   else if (len == sizeof (char))
 178     x = n->ic;
 179 #ifdef Allow_TYQUAD
 180   else if (len == sizeof (longint))
 181     x = n->ili;
 182 #endif
 183   else
 184     x = n->is;
 185   ans = f__icvt (x, &ndigit, &sign, base);
 186   if (sign || f__cplus)
 187     xsign = 1;
 188   else
 189     xsign = 0;
 190   if (ndigit + xsign > w || m + xsign > w)
 191     {
 192       for (i = 0; i < w; i++)
 193         (*f__putn) ('*');
 194       return (0);
 195     }
 196   if (x == 0 && m == 0)
 197     {
 198       for (i = 0; i < w; i++)
 199         (*f__putn) (' ');
 200       return (0);
 201     }
 202   if (ndigit >= m)
 203     spare = w - ndigit - xsign;
 204   else
 205     spare = w - m - xsign;
 206   for (i = 0; i < spare; i++)
 207     (*f__putn) (' ');
 208   if (sign)
 209     (*f__putn) ('-');
 210   else if (f__cplus)
 211     (*f__putn) ('+');
 212   for (i = 0; i < m - ndigit; i++)
 213     (*f__putn) ('0');
 214   for (i = 0; i < ndigit; i++)
 215     (*f__putn) (*ans++);
 216   return (0);
 217 }
 218 static int
 219 wrt_AP (char *s)
 220 {
 221   char quote;
 222   int i;
 223
 224   if (f__cursor && (i = mv_cur ()))
 225     return i;
 226   quote = *s++;
 227   for (; *s; s++)
 228     {
 229       if (*s != quote)
 230         (*f__putn) (*s);
 231       else if (*++s == quote)
 232         (*f__putn) (*s);
 233       else
 234         return (1);
 235     }
 236   return (1);
 237 }
 238 static int
 239 wrt_H (int a, char *s)
 240 {
 241   int i;
 242
 243   if (f__cursor && (i = mv_cur ()))
 244     return i;
 245   while (a--)
 246     (*f__putn) (*s++);
 247   return (1);
 248 }
 249
 250 int
 251 wrt_L (Uint * n, int len, ftnlen sz)
 252 {
 253   int i;
 254   long x;
 255   if (sizeof (long) == sz)
 256     x = n->il;
 257   else if (sz == sizeof (char))
 258     x = n->ic;
 259   else
 260     x = n->is;
 261   for (i = 0; i < len - 1; i++)
 262     (*f__putn) (' ');
 263   if (x)
 264     (*f__putn) ('T');
 265   else
 266     (*f__putn) ('F');
 267   return (0);
 268 }
 269 static int
 270 wrt_A (char *p, ftnlen len)
 271 {
 272   while (len-- > 0)
 273     (*f__putn) (*p++);
 274   return (0);
 275 }
 276 static int
 277 wrt_AW (char *p, int w, ftnlen len)
 278 {
 279   while (w > len)
 280     {
 281       w--;
 282       (*f__putn) (' ');
 283     }
 284   while (w-- > 0)
 285     (*f__putn) (*p++);
 286   return (0);
 287 }
 288
 289 static int
 290 wrt_G (ufloat * p, int w, int d, int e, ftnlen len)
 291 {
 292   double up = 1, x;
 293   int i = 0, oldscale, n, j;
 294   x = len == sizeof (real) ? p->pf : p->pd;
 295   if (x < 0)
 296     x = -x;
 297   if (x < .1)
 298     {
 299       if (x != 0.)
 300         return (wrt_E (p, w, d, e, len));
 301       i = 1;
 302       goto have_i;
 303     }
 304   for (; i <= d; i++, up *= 10)
 305     {
 306       if (x >= up)
 307         continue;
 308     have_i:
 309       oldscale = f__scale;
 310       f__scale = 0;
 311       if (e == 0)
 312         n = 4;
 313       else
 314         n = e + 2;
 315       i = wrt_F (p, w - n, d - i, len);
 316       for (j = 0; j < n; j++)
 317         (*f__putn) (' ');
 318       f__scale = oldscale;
 319       return (i);
 320     }
 321   return (wrt_E (p, w, d, e, len));
 322 }
 323
 324 int
 325 w_ed (struct syl * p, char *ptr, ftnlen len)
 326 {
 327   int i;
 328
 329   if (f__cursor && (i = mv_cur ()))
 330     return i;
 331   switch (p->op)
 332     {
 333     default:
 334       fprintf (stderr, "w_ed, unexpected code: %d\n", p->op);
 335       sig_die (f__fmtbuf, 1);
 336     case I:
 337       return (wrt_I ((Uint *) ptr, p->p1, len, 10));
 338     case IM:
 339       return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 10));
 340
 341       /* O and OM don't work right for character, double, complex, */
 342       /* or doublecomplex, and they differ from Fortran 90 in */
 343       /* showing a minus sign for negative values. */
 344
 345     case O:
 346       return (wrt_I ((Uint *) ptr, p->p1, len, 8));
 347     case OM:
 348       return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 8));
 349     case L:
 350       return (wrt_L ((Uint *) ptr, p->p1, len));
 351     case A:
 352       return (wrt_A (ptr, len));
 353     case AW:
 354       return (wrt_AW (ptr, p->p1, len));
 355     case D:
 356     case E:
 357     case EE:
 358       return (wrt_E ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
 359     case G:
 360     case GE:
 361       return (wrt_G ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
 362     case F:
 363       return (wrt_F ((ufloat *) ptr, p->p1, p->p2.i[0], len));
 364
 365       /* Z and ZM assume 8-bit bytes. */
 366
 367     case Z:
 368       return (wrt_Z ((Uint *) ptr, p->p1, 0, len));
 369     case ZM:
 370       return (wrt_Z ((Uint *) ptr, p->p1, p->p2.i[0], len));
 371     }
 372 }
 373
 374 int
 375 w_ned (struct syl * p)
 376 {
 377   switch (p->op)
 378     {
 379     default:
 380       fprintf (stderr, "w_ned, unexpected code: %d\n", p->op);
 381       sig_die (f__fmtbuf, 1);
 382     case SLASH:
 383       return ((*f__donewrec) ());
 384     case T:
 385       f__cursor = p->p1 - f__recpos - 1;
 386       return (1);
 387     case TL:
 388       f__cursor -= p->p1;
 389       if (f__cursor < -f__recpos)       /* TL1000, 1X */
 390         f__cursor = -f__recpos;
 391       return (1);
 392     case TR:
 393     case X:
 394       f__cursor += p->p1;
 395       return (1);
 396     case APOS:
 397       return (wrt_AP (p->p2.s));
 398     case H:
 399       return (wrt_H (p->p1, p->p2.s));
 400     }
 401 }