contrib/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   longint x;
 255 #ifdef Allow_TYQUAD
 256   if (sizeof (longint) == sz)
 257     x = n->ili;
 258   else
 259 #endif
 260   if (sizeof (short ) == sz)
 261     x = n->is;
 262   else if (sizeof (char) == sz)
 263     x = n->ic;
 264   else if (sizeof (integer) == sz)
 265     x = n->il;
 266
 267   for (i = 0; i < len - 1; i++)
 268     (*f__putn) (' ');
 269   if (x)
 270     (*f__putn) ('T');
 271   else
 272     (*f__putn) ('F');
 273   return (0);
 274 }
 275 static int
 276 wrt_A (char *p, ftnlen len)
 277 {
 278   while (len-- > 0)
 279     (*f__putn) (*p++);
 280   return (0);
 281 }
 282 static int
 283 wrt_AW (char *p, int w, ftnlen len)
 284 {
 285   while (w > len)
 286     {
 287       w--;
 288       (*f__putn) (' ');
 289     }
 290   while (w-- > 0)
 291     (*f__putn) (*p++);
 292   return (0);
 293 }
 294
 295 static int
 296 wrt_G (ufloat * p, int w, int d, int e, ftnlen len)
 297 {
 298   double up = 1, x;
 299   int i = 0, oldscale, n, j;
 300   x = len == sizeof (real) ? p->pf : p->pd;
 301   if (x < 0)
 302     x = -x;
 303   if (x < .1)
 304     {
 305       if (x != 0.)
 306         return (wrt_E (p, w, d, e, len));
 307       i = 1;
 308       goto have_i;
 309     }
 310   for (; i <= d; i++, up *= 10)
 311     {
 312       if (x >= up)
 313         continue;
 314     have_i:
 315       oldscale = f__scale;
 316       f__scale = 0;
 317       if (e == 0)
 318         n = 4;
 319       else
 320         n = e + 2;
 321       i = wrt_F (p, w - n, d - i, len);
 322       for (j = 0; j < n; j++)
 323         (*f__putn) (' ');
 324       f__scale = oldscale;
 325       return (i);
 326     }
 327   return (wrt_E (p, w, d, e, len));
 328 }
 329
 330 int
 331 w_ed (struct syl * p, char *ptr, ftnlen len)
 332 {
 333   int i;
 334
 335   if (f__cursor && (i = mv_cur ()))
 336     return i;
 337   switch (p->op)
 338     {
 339     default:
 340       fprintf (stderr, "w_ed, unexpected code: %d\n", p->op);
 341       sig_die (f__fmtbuf, 1);
 342     case I:
 343       return (wrt_I ((Uint *) ptr, p->p1, len, 10));
 344     case IM:
 345       return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 10));
 346
 347       /* O and OM don't work right for character, double, complex, */
 348       /* or doublecomplex, and they differ from Fortran 90 in */
 349       /* showing a minus sign for negative values. */
 350
 351     case O:
 352       return (wrt_I ((Uint *) ptr, p->p1, len, 8));
 353     case OM:
 354       return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 8));
 355     case L:
 356       return (wrt_L ((Uint *) ptr, p->p1, len));
 357     case A:
 358       return (wrt_A (ptr, len));
 359     case AW:
 360       return (wrt_AW (ptr, p->p1, len));
 361     case D:
 362     case E:
 363     case EE:
 364       return (wrt_E ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
 365     case G:
 366     case GE:
 367       return (wrt_G ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
 368     case F:
 369       return (wrt_F ((ufloat *) ptr, p->p1, p->p2.i[0], len));
 370
 371       /* Z and ZM assume 8-bit bytes. */
 372
 373     case Z:
 374       return (wrt_Z ((Uint *) ptr, p->p1, 0, len));
 375     case ZM:
 376       return (wrt_Z ((Uint *) ptr, p->p1, p->p2.i[0], len));
 377     }
 378 }
 379
 380 int
 381 w_ned (struct syl * p)
 382 {
 383   switch (p->op)
 384     {
 385     default:
 386       fprintf (stderr, "w_ned, unexpected code: %d\n", p->op);
 387       sig_die (f__fmtbuf, 1);
 388     case SLASH:
 389       return ((*f__donewrec) ());
 390     case T:
 391       f__cursor = p->p1 - f__recpos - 1;
 392       return (1);
 393     case TL:
 394       f__cursor -= p->p1;
 395       if (f__cursor < -f__recpos)       /* TL1000, 1X */
 396         f__cursor = -f__recpos;
 397       return (1);
 398     case TR:
 399     case X:
 400       f__cursor += p->p1;
 401       return (1);
 402     case APOS:
 403       return (wrt_AP (p->p2.s));
 404     case H:
 405       return (wrt_H (p->p1, p->p2.s));
 406     }
 407 }