summaryrefslogtreecommitdiff
path: root/libf2c/libI77/fmt.c
diff options
context:
space:
mode:
Diffstat (limited to 'libf2c/libI77/fmt.c')
-rw-r--r--libf2c/libI77/fmt.c602
1 files changed, 0 insertions, 602 deletions
diff --git a/libf2c/libI77/fmt.c b/libf2c/libI77/fmt.c
deleted file mode 100644
index fa9b73cd60e..00000000000
--- a/libf2c/libI77/fmt.c
+++ /dev/null
@@ -1,602 +0,0 @@
-#include "config.h"
-#include "f2c.h"
-#include "fio.h"
-#include "fmt.h"
-#define skip(s) while(*s==' ') s++
-#ifdef interdata
-#define SYLMX 300
-#endif
-#ifdef pdp11
-#define SYLMX 300
-#endif
-#ifdef vax
-#define SYLMX 300
-#endif
-#ifndef SYLMX
-#define SYLMX 300
-#endif
-#define GLITCH '\2'
- /* special quote character for stu */
-extern int f__cursor, f__scale;
-extern flag f__cblank, f__cplus; /*blanks in I and compulsory plus */
-static struct syl f__syl[SYLMX];
-int f__parenlvl, f__pc, f__revloc;
-
-static char *
-ap_end (char *s)
-{
- char quote;
- quote = *s++;
- for (; *s; s++)
- {
- if (*s != quote)
- continue;
- if (*++s != quote)
- return (s);
- }
- if (f__elist->cierr)
- {
- errno = 100;
- return (NULL);
- }
- f__fatal (100, "bad string");
- /*NOTREACHED*/ return 0;
-}
-
-static int
-op_gen (int a, int b, int c, int d)
-{
- struct syl *p = &f__syl[f__pc];
- if (f__pc >= SYLMX)
- {
- fprintf (stderr, "format too complicated:\n");
- sig_die (f__fmtbuf, 1);
- }
- p->op = a;
- p->p1 = b;
- p->p2.i[0] = c;
- p->p2.i[1] = d;
- return (f__pc++);
-}
-static char *f_list (char *);
-static char *
-gt_num (char *s, int *n, int n1)
-{
- int m = 0, f__cnt = 0;
- char c;
- for (c = *s;; c = *s)
- {
- if (c == ' ')
- {
- s++;
- continue;
- }
- if (c > '9' || c < '0')
- break;
- m = 10 * m + c - '0';
- f__cnt++;
- s++;
- }
- if (f__cnt == 0)
- {
- if (!n1)
- s = 0;
- *n = n1;
- }
- else
- *n = m;
- return (s);
-}
-
-static char *
-f_s (char *s, int curloc)
-{
- skip (s);
- if (*s++ != '(')
- {
- return (NULL);
- }
- if (f__parenlvl++ == 1)
- f__revloc = curloc;
- if (op_gen (RET1, curloc, 0, 0) < 0 || (s = f_list (s)) == NULL)
- {
- return (NULL);
- }
- return (s);
-}
-
-static int
-ne_d (char *s, char **p)
-{
- int n, x, sign = 0;
- struct syl *sp;
- switch (*s)
- {
- default:
- return (0);
- case ':':
- (void) op_gen (COLON, 0, 0, 0);
- break;
- case '$':
- (void) op_gen (NONL, 0, 0, 0);
- break;
- case 'B':
- case 'b':
- if (*++s == 'z' || *s == 'Z')
- (void) op_gen (BZ, 0, 0, 0);
- else
- (void) op_gen (BN, 0, 0, 0);
- break;
- case 'S':
- case 's':
- if (*(s + 1) == 's' || *(s + 1) == 'S')
- {
- x = SS;
- s++;
- }
- else if (*(s + 1) == 'p' || *(s + 1) == 'P')
- {
- x = SP;
- s++;
- }
- else
- x = S;
- (void) op_gen (x, 0, 0, 0);
- break;
- case '/':
- (void) op_gen (SLASH, 0, 0, 0);
- break;
- case '-':
- sign = 1;
- case '+':
- s++; /*OUTRAGEOUS CODING TRICK */
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- if (!(s = gt_num (s, &n, 0)))
- {
- bad:*p = 0;
- return 1;
- }
- switch (*s)
- {
- default:
- return (0);
- case 'P':
- case 'p':
- if (sign)
- n = -n;
- (void) op_gen (P, n, 0, 0);
- break;
- case 'X':
- case 'x':
- (void) op_gen (X, n, 0, 0);
- break;
- case 'H':
- case 'h':
- sp = &f__syl[op_gen (H, n, 0, 0)];
- sp->p2.s = s + 1;
- s += n;
- break;
- }
- break;
- case GLITCH:
- case '"':
- case '\'':
- sp = &f__syl[op_gen (APOS, 0, 0, 0)];
- sp->p2.s = s;
- if ((*p = ap_end (s)) == NULL)
- return (0);
- return (1);
- case 'T':
- case 't':
- if (*(s + 1) == 'l' || *(s + 1) == 'L')
- {
- x = TL;
- s++;
- }
- else if (*(s + 1) == 'r' || *(s + 1) == 'R')
- {
- x = TR;
- s++;
- }
- else
- x = T;
- if (!(s = gt_num (s + 1, &n, 0)))
- goto bad;
- s--;
- (void) op_gen (x, n, 0, 0);
- break;
- case 'X':
- case 'x':
- (void) op_gen (X, 1, 0, 0);
- break;
- case 'P':
- case 'p':
- (void) op_gen (P, 1, 0, 0);
- break;
- }
- s++;
- *p = s;
- return (1);
-}
-
-static int
-e_d (char *s, char **p)
-{
- int i, im, n, w, d, e, found = 0, x = 0;
- char *sv = s;
- s = gt_num (s, &n, 1);
- (void) op_gen (STACK, n, 0, 0);
- switch (*s++)
- {
- default:
- break;
- case 'E':
- case 'e':
- x = 1;
- case 'G':
- case 'g':
- found = 1;
- if (!(s = gt_num (s, &w, 0)))
- {
- bad:
- *p = 0;
- return 1;
- }
- if (w == 0)
- break;
- if (*s == '.')
- {
- if (!(s = gt_num (s + 1, &d, 0)))
- goto bad;
- }
- else
- d = 0;
- if (*s != 'E' && *s != 'e')
- (void) op_gen (x == 1 ? E : G, w, d, 0); /* default is Ew.dE2 */
- else
- {
- if (!(s = gt_num (s + 1, &e, 0)))
- goto bad;
- (void) op_gen (x == 1 ? EE : GE, w, d, e);
- }
- break;
- case 'O':
- case 'o':
- i = O;
- im = OM;
- goto finish_I;
- case 'Z':
- case 'z':
- i = Z;
- im = ZM;
- goto finish_I;
- case 'L':
- case 'l':
- found = 1;
- if (!(s = gt_num (s, &w, 0)))
- goto bad;
- if (w == 0)
- break;
- (void) op_gen (L, w, 0, 0);
- break;
- case 'A':
- case 'a':
- found = 1;
- skip (s);
- if (*s >= '0' && *s <= '9')
- {
- s = gt_num (s, &w, 1);
- if (w == 0)
- break;
- (void) op_gen (AW, w, 0, 0);
- break;
- }
- (void) op_gen (A, 0, 0, 0);
- break;
- case 'F':
- case 'f':
- if (!(s = gt_num (s, &w, 0)))
- goto bad;
- found = 1;
- if (w == 0)
- break;
- if (*s == '.')
- {
- if (!(s = gt_num (s + 1, &d, 0)))
- goto bad;
- }
- else
- d = 0;
- (void) op_gen (F, w, d, 0);
- break;
- case 'D':
- case 'd':
- found = 1;
- if (!(s = gt_num (s, &w, 0)))
- goto bad;
- if (w == 0)
- break;
- if (*s == '.')
- {
- if (!(s = gt_num (s + 1, &d, 0)))
- goto bad;
- }
- else
- d = 0;
- (void) op_gen (D, w, d, 0);
- break;
- case 'I':
- case 'i':
- i = I;
- im = IM;
- finish_I:
- if (!(s = gt_num (s, &w, 0)))
- goto bad;
- found = 1;
- if (w == 0)
- break;
- if (*s != '.')
- {
- (void) op_gen (i, w, 0, 0);
- break;
- }
- if (!(s = gt_num (s + 1, &d, 0)))
- goto bad;
- (void) op_gen (im, w, d, 0);
- break;
- }
- if (found == 0)
- {
- f__pc--; /*unSTACK */
- *p = sv;
- return (0);
- }
- *p = s;
- return (1);
-}
-static char *
-i_tem (char *s)
-{
- char *t;
- int n, curloc;
- if (*s == ')')
- return (s);
- if (ne_d (s, &t))
- return (t);
- if (e_d (s, &t))
- return (t);
- s = gt_num (s, &n, 1);
- if ((curloc = op_gen (STACK, n, 0, 0)) < 0)
- return (NULL);
- return (f_s (s, curloc));
-}
-
-static char *
-f_list (char *s)
-{
- for (; *s != 0;)
- {
- skip (s);
- if ((s = i_tem (s)) == NULL)
- return (NULL);
- skip (s);
- if (*s == ',')
- s++;
- else if (*s == ')')
- {
- if (--f__parenlvl == 0)
- {
- (void) op_gen (REVERT, f__revloc, 0, 0);
- return (++s);
- }
- (void) op_gen (GOTO, 0, 0, 0);
- return (++s);
- }
- }
- return (NULL);
-}
-
-int
-pars_f (char *s)
-{
- char *e;
-
- f__parenlvl = f__revloc = f__pc = 0;
- if ((e = f_s (s, 0)) == NULL)
- {
- /* Try and delimit the format string. Parens within
- hollerith and quoted strings have to match for this
- to work, but it's probably adequate for most needs.
- Note that this is needed because a valid CHARACTER
- variable passed for FMT= can contain '(I)garbage',
- where `garbage' is billions and billions of junk
- characters, and it's up to the run-time library to
- know where the format string ends by counting parens.
- Meanwhile, still treat NUL byte as "hard stop", since
- f2c still appends that at end of FORMAT-statement
- strings. */
-
- int level = 0;
-
- for (f__fmtlen = 0;
- ((*s != ')') || (--level > 0))
- && (*s != '\0') && (f__fmtlen < 80); ++s, ++f__fmtlen)
- {
- if (*s == '(')
- ++level;
- }
- if (*s == ')')
- ++f__fmtlen;
- return (-1);
- }
- f__fmtlen = e - s;
- return (0);
-}
-
-#define STKSZ 10
-int f__cnt[STKSZ], f__ret[STKSZ], f__cp, f__rp;
-flag f__workdone, f__nonl;
-
-static int
-type_f (int n)
-{
- switch (n)
- {
- default:
- return (n);
- case RET1:
- return (RET1);
- case REVERT:
- return (REVERT);
- case GOTO:
- return (GOTO);
- case STACK:
- return (STACK);
- case X:
- case SLASH:
- case APOS:
- case H:
- case T:
- case TL:
- case TR:
- return (NED);
- case F:
- case I:
- case IM:
- case A:
- case AW:
- case O:
- case OM:
- case L:
- case E:
- case EE:
- case D:
- case G:
- case GE:
- case Z:
- case ZM:
- return (ED);
- }
-}
-integer
-do_fio (ftnint * number, char *ptr, ftnlen len)
-{
- struct syl *p;
- int n, i;
- for (i = 0; i < *number; i++, ptr += len)
- {
- loop:switch (type_f ((p = &f__syl[f__pc])->op))
- {
- default:
- fprintf (stderr, "unknown code in do_fio: %d\n%.*s\n",
- p->op, f__fmtlen, f__fmtbuf);
- err (f__elist->cierr, 100, "do_fio");
- case NED:
- if ((*f__doned) (p))
- {
- f__pc++;
- goto loop;
- }
- f__pc++;
- continue;
- case ED:
- if (f__cnt[f__cp] <= 0)
- {
- f__cp--;
- f__pc++;
- goto loop;
- }
- if (ptr == NULL)
- return ((*f__doend) ());
- f__cnt[f__cp]--;
- f__workdone = 1;
- if ((n = (*f__doed) (p, ptr, len)) > 0)
- errfl (f__elist->cierr, errno, "fmt");
- if (n < 0)
- err (f__elist->ciend, (EOF), "fmt");
- continue;
- case STACK:
- f__cnt[++f__cp] = p->p1;
- f__pc++;
- goto loop;
- case RET1:
- f__ret[++f__rp] = p->p1;
- f__pc++;
- goto loop;
- case GOTO:
- if (--f__cnt[f__cp] <= 0)
- {
- f__cp--;
- f__rp--;
- f__pc++;
- goto loop;
- }
- f__pc = 1 + f__ret[f__rp--];
- goto loop;
- case REVERT:
- f__rp = f__cp = 0;
- f__pc = p->p1;
- if (ptr == NULL)
- return ((*f__doend) ());
- if (!f__workdone)
- return (0);
- if ((n = (*f__dorevert) ()) != 0)
- return (n);
- goto loop;
- case COLON:
- if (ptr == NULL)
- return ((*f__doend) ());
- f__pc++;
- goto loop;
- case NONL:
- f__nonl = 1;
- f__pc++;
- goto loop;
- case S:
- case SS:
- f__cplus = 0;
- f__pc++;
- goto loop;
- case SP:
- f__cplus = 1;
- f__pc++;
- goto loop;
- case P:
- f__scale = p->p1;
- f__pc++;
- goto loop;
- case BN:
- f__cblank = 0;
- f__pc++;
- goto loop;
- case BZ:
- f__cblank = 1;
- f__pc++;
- goto loop;
- }
- }
- return (0);
-}
-
-int
-en_fio (void)
-{
- ftnint one = 1;
- return (do_fio (&one, (char *) NULL, (ftnint) 0));
-}
-
-void
-fmt_bg (void)
-{
- f__workdone = f__cp = f__rp = f__pc = f__cursor = 0;
- f__cnt[0] = f__ret[0] = 0;
-}
View Lorry Controller Status