diff options
Diffstat (limited to 'contrib/libf2c/libI77/fmt.c')
| -rw-r--r-- | contrib/libf2c/libI77/fmt.c | 602 |
1 files changed, 602 insertions, 0 deletions
diff --git a/contrib/libf2c/libI77/fmt.c b/contrib/libf2c/libI77/fmt.c new file mode 100644 index 0000000..fa9b73c --- /dev/null +++ b/contrib/libf2c/libI77/fmt.c @@ -0,0 +1,602 @@ +#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; +} |
