+++ /dev/null
-#include "config.h"
-#include "f2c.h"
-#include "fio.h"
-#include "fmt.h"
-
-extern icilist *f__svic;
-extern char *f__icptr;
-
-static int
-mv_cur (void) /* shouldn't use fseek because it insists on calling fflush */
- /* instead we know too much about stdio */
-{
- int cursor = f__cursor;
- f__cursor = 0;
- if (f__external == 0)
- {
- if (cursor < 0)
- {
- if (f__hiwater < f__recpos)
- f__hiwater = f__recpos;
- f__recpos += cursor;
- f__icptr += cursor;
- if (f__recpos < 0)
- err (f__elist->cierr, 110, "left off");
- }
- else if (cursor > 0)
- {
- if (f__recpos + cursor >= f__svic->icirlen)
- err (f__elist->cierr, 110, "recend");
- if (f__hiwater <= f__recpos)
- for (; cursor > 0; cursor--)
- (*f__putn) (' ');
- else if (f__hiwater <= f__recpos + cursor)
- {
- cursor -= f__hiwater - f__recpos;
- f__icptr += f__hiwater - f__recpos;
- f__recpos = f__hiwater;
- for (; cursor > 0; cursor--)
- (*f__putn) (' ');
- }
- else
- {
- f__icptr += cursor;
- f__recpos += cursor;
- }
- }
- return (0);
- }
- if (cursor > 0)
- {
- if (f__hiwater <= f__recpos)
- for (; cursor > 0; cursor--)
- (*f__putn) (' ');
- else if (f__hiwater <= f__recpos + cursor)
- {
- cursor -= f__hiwater - f__recpos;
- f__recpos = f__hiwater;
- for (; cursor > 0; cursor--)
- (*f__putn) (' ');
- }
- else
- {
- f__recpos += cursor;
- }
- }
- else if (cursor < 0)
- {
- if (cursor + f__recpos < 0)
- err (f__elist->cierr, 110, "left off");
- if (f__hiwater < f__recpos)
- f__hiwater = f__recpos;
- f__recpos += cursor;
- }
- return (0);
-}
-
-static int
-wrt_Z (Uint * n, int w, int minlen, ftnlen len)
-{
- register char *s, *se;
- register int i, w1;
- static int one = 1;
- static char hex[] = "0123456789ABCDEF";
- s = (char *) n;
- --len;
- if (*(char *) &one)
- {
- /* little endian */
- se = s;
- s += len;
- i = -1;
- }
- else
- {
- se = s + len;
- i = 1;
- }
- for (;; s += i)
- if (s == se || *s)
- break;
- w1 = (i * (se - s) << 1) + 1;
- if (*s & 0xf0)
- w1++;
- if (w1 > w)
- for (i = 0; i < w; i++)
- (*f__putn) ('*');
- else
- {
- if ((minlen -= w1) > 0)
- w1 += minlen;
- while (--w >= w1)
- (*f__putn) (' ');
- while (--minlen >= 0)
- (*f__putn) ('0');
- if (!(*s & 0xf0))
- {
- (*f__putn) (hex[*s & 0xf]);
- if (s == se)
- return 0;
- s += i;
- }
- for (;; s += i)
- {
- (*f__putn) (hex[*s >> 4 & 0xf]);
- (*f__putn) (hex[*s & 0xf]);
- if (s == se)
- break;
- }
- }
- return 0;
-}
-
-static int
-wrt_I (Uint * n, int w, ftnlen len, register int base)
-{
- int ndigit, sign, spare, i;
- longint x;
- char *ans;
- if (len == sizeof (integer))
- x = n->il;
- else if (len == sizeof (char))
- x = n->ic;
-#ifdef Allow_TYQUAD
- else if (len == sizeof (longint))
- x = n->ili;
-#endif
- else
- x = n->is;
- ans = f__icvt (x, &ndigit, &sign, base);
- spare = w - ndigit;
- if (sign || f__cplus)
- spare--;
- if (spare < 0)
- for (i = 0; i < w; i++)
- (*f__putn) ('*');
- else
- {
- for (i = 0; i < spare; i++)
- (*f__putn) (' ');
- if (sign)
- (*f__putn) ('-');
- else if (f__cplus)
- (*f__putn) ('+');
- for (i = 0; i < ndigit; i++)
- (*f__putn) (*ans++);
- }
- return (0);
-}
-static int
-wrt_IM (Uint * n, int w, int m, ftnlen len, int base)
-{
- int ndigit, sign, spare, i, xsign;
- longint x;
- char *ans;
- if (sizeof (integer) == len)
- x = n->il;
- else if (len == sizeof (char))
- x = n->ic;
-#ifdef Allow_TYQUAD
- else if (len == sizeof (longint))
- x = n->ili;
-#endif
- else
- x = n->is;
- ans = f__icvt (x, &ndigit, &sign, base);
- if (sign || f__cplus)
- xsign = 1;
- else
- xsign = 0;
- if (ndigit + xsign > w || m + xsign > w)
- {
- for (i = 0; i < w; i++)
- (*f__putn) ('*');
- return (0);
- }
- if (x == 0 && m == 0)
- {
- for (i = 0; i < w; i++)
- (*f__putn) (' ');
- return (0);
- }
- if (ndigit >= m)
- spare = w - ndigit - xsign;
- else
- spare = w - m - xsign;
- for (i = 0; i < spare; i++)
- (*f__putn) (' ');
- if (sign)
- (*f__putn) ('-');
- else if (f__cplus)
- (*f__putn) ('+');
- for (i = 0; i < m - ndigit; i++)
- (*f__putn) ('0');
- for (i = 0; i < ndigit; i++)
- (*f__putn) (*ans++);
- return (0);
-}
-static int
-wrt_AP (char *s)
-{
- char quote;
- int i;
-
- if (f__cursor && (i = mv_cur ()))
- return i;
- quote = *s++;
- for (; *s; s++)
- {
- if (*s != quote)
- (*f__putn) (*s);
- else if (*++s == quote)
- (*f__putn) (*s);
- else
- return (1);
- }
- return (1);
-}
-static int
-wrt_H (int a, char *s)
-{
- int i;
-
- if (f__cursor && (i = mv_cur ()))
- return i;
- while (a--)
- (*f__putn) (*s++);
- return (1);
-}
-
-int
-wrt_L (Uint * n, int len, ftnlen sz)
-{
- int i;
- long x;
- if (sizeof (long) == sz)
- x = n->il;
- else if (sz == sizeof (char))
- x = n->ic;
- else
- x = n->is;
- for (i = 0; i < len - 1; i++)
- (*f__putn) (' ');
- if (x)
- (*f__putn) ('T');
- else
- (*f__putn) ('F');
- return (0);
-}
-static int
-wrt_A (char *p, ftnlen len)
-{
- while (len-- > 0)
- (*f__putn) (*p++);
- return (0);
-}
-static int
-wrt_AW (char *p, int w, ftnlen len)
-{
- while (w > len)
- {
- w--;
- (*f__putn) (' ');
- }
- while (w-- > 0)
- (*f__putn) (*p++);
- return (0);
-}
-
-static int
-wrt_G (ufloat * p, int w, int d, int e, ftnlen len)
-{
- double up = 1, x;
- int i = 0, oldscale, n, j;
- x = len == sizeof (real) ? p->pf : p->pd;
- if (x < 0)
- x = -x;
- if (x < .1)
- {
- if (x != 0.)
- return (wrt_E (p, w, d, e, len));
- i = 1;
- goto have_i;
- }
- for (; i <= d; i++, up *= 10)
- {
- if (x >= up)
- continue;
- have_i:
- oldscale = f__scale;
- f__scale = 0;
- if (e == 0)
- n = 4;
- else
- n = e + 2;
- i = wrt_F (p, w - n, d - i, len);
- for (j = 0; j < n; j++)
- (*f__putn) (' ');
- f__scale = oldscale;
- return (i);
- }
- return (wrt_E (p, w, d, e, len));
-}
-
-int
-w_ed (struct syl * p, char *ptr, ftnlen len)
-{
- int i;
-
- if (f__cursor && (i = mv_cur ()))
- return i;
- switch (p->op)
- {
- default:
- fprintf (stderr, "w_ed, unexpected code: %d\n", p->op);
- sig_die (f__fmtbuf, 1);
- case I:
- return (wrt_I ((Uint *) ptr, p->p1, len, 10));
- case IM:
- return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 10));
-
- /* O and OM don't work right for character, double, complex, */
- /* or doublecomplex, and they differ from Fortran 90 in */
- /* showing a minus sign for negative values. */
-
- case O:
- return (wrt_I ((Uint *) ptr, p->p1, len, 8));
- case OM:
- return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 8));
- case L:
- return (wrt_L ((Uint *) ptr, p->p1, len));
- case A:
- return (wrt_A (ptr, len));
- case AW:
- return (wrt_AW (ptr, p->p1, len));
- case D:
- case E:
- case EE:
- return (wrt_E ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
- case G:
- case GE:
- return (wrt_G ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
- case F:
- return (wrt_F ((ufloat *) ptr, p->p1, p->p2.i[0], len));
-
- /* Z and ZM assume 8-bit bytes. */
-
- case Z:
- return (wrt_Z ((Uint *) ptr, p->p1, 0, len));
- case ZM:
- return (wrt_Z ((Uint *) ptr, p->p1, p->p2.i[0], len));
- }
-}
-
-int
-w_ned (struct syl * p)
-{
- switch (p->op)
- {
- default:
- fprintf (stderr, "w_ned, unexpected code: %d\n", p->op);
- sig_die (f__fmtbuf, 1);
- case SLASH:
- return ((*f__donewrec) ());
- case T:
- f__cursor = p->p1 - f__recpos - 1;
- return (1);
- case TL:
- f__cursor -= p->p1;
- if (f__cursor < -f__recpos) /* TL1000, 1X */
- f__cursor = -f__recpos;
- return (1);
- case TR:
- case X:
- f__cursor += p->p1;
- return (1);
- case APOS:
- return (wrt_AP (p->p2.s));
- case H:
- return (wrt_H (p->p1, p->p2.s));
- }
-}
OSDN Git Service
