From 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 Mon Sep 17 00:00:00 2001 From: Joe Hunkeler Date: Tue, 11 Aug 2015 16:51:37 -0400 Subject: Repatch (from linux) of OSX IRAF --- unix/f2c/src/pread.c | 990 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 990 insertions(+) create mode 100644 unix/f2c/src/pread.c (limited to 'unix/f2c/src/pread.c') diff --git a/unix/f2c/src/pread.c b/unix/f2c/src/pread.c new file mode 100644 index 00000000..40152182 --- /dev/null +++ b/unix/f2c/src/pread.c @@ -0,0 +1,990 @@ +/**************************************************************** +Copyright 1990, 1992, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +#include "defs.h" + + static char Ptok[128], Pct[Table_size]; + static char *Pfname; + static long Plineno; + static int Pbad; + static int *tfirst, *tlast, *tnext, tmax; + +#define P_space 1 +#define P_anum 2 +#define P_delim 3 +#define P_slash 4 + +#define TGULP 100 + + static void +trealloc(Void) +{ + int k = tmax; + tfirst = (int *)realloc((char *)tfirst, + (tmax += TGULP)*sizeof(int)); + if (!tfirst) { + fprintf(stderr, + "Pfile: realloc failure!\n"); + exit(2); + } + tlast = tfirst + tmax; + tnext = tfirst + k; + } + + static void +#ifdef KR_headers +badchar(c) + int c; +#else +badchar(int c) +#endif +{ + fprintf(stderr, + "unexpected character 0x%.2x = '%c' on line %ld of %s\n", + c, c, Plineno, Pfname); + exit(2); + } + + static void +bad_type(Void) +{ + fprintf(stderr, + "unexpected type \"%s\" on line %ld of %s\n", + Ptok, Plineno, Pfname); + exit(2); + } + + static void +#ifdef KR_headers +badflag(tname, option) + char *tname; + char *option; +#else +badflag(char *tname, char *option) +#endif +{ + fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n", + tname, option, Plineno, Pfname); + Pbad++; + } + + static void +#ifdef KR_headers +detected(msg) + char *msg; +#else +detected(char *msg) +#endif +{ + fprintf(stderr, + "%sdetected on line %ld of %s\n", msg, Plineno, Pfname); + Pbad++; + } + +#if 0 + static void +#ifdef KR_headers +checklogical(k) + int k; +#else +checklogical(int k) +#endif +{ + static int lastmsg = 0; + static int seen[2] = {0,0}; + + seen[k] = 1; + if (seen[1-k]) { + if (lastmsg < 3) { + lastmsg = 3; + detected( + "Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t"); + } + return; + } + if (k) { + if (tylogical == TYLONG || lastmsg >= 2) + return; + if (!lastmsg) { + lastmsg = 2; + badflag("LOGICAL", "I4"); + } + } + else { + if (tylogical == TYSHORT || lastmsg & 1) + return; + if (!lastmsg) { + lastmsg = 1; + badflag("LOGICAL", "i2` or `f2c -I2"); + } + } + } +#else +#define checklogical(n) /* */ +#endif + + static void +#ifdef KR_headers +checkreal(k) + int k; +#else +checkreal(int k) +#endif +{ + static int warned = 0; + static int seen[2] = {0,0}; + + seen[k] = 1; + if (seen[1-k]) { + if (warned < 2) + detected("Illegal mixture of -R and -!R "); + warned = 2; + return; + } + if (k == forcedouble || warned) + return; + warned = 1; + badflag("REAL return", (char*)(k ? "!R" : "R")); + } + + static void +#ifdef KR_headers +Pnotboth(e) + Extsym *e; +#else +Pnotboth(Extsym *e) +#endif +{ + if (e->curno) + return; + Pbad++; + e->curno = 1; + fprintf(stderr, + "%s cannot be both a procedure and a common block (line %ld of %s)\n", + e->fextname, Plineno, Pfname); + } + + static int +#ifdef KR_headers +numread(pf, n) + register FILE *pf; + int *n; +#else +numread(register FILE *pf, int *n) +#endif +{ + register int c, k; + + if ((c = getc(pf)) < '0' || c > '9') + return c; + k = c - '0'; + for(;;) { + if ((c = getc(pf)) == ' ') { + *n = k; + return c; + } + if (c < '0' || c > '9') + break; + k = 10*k + c - '0'; + } + return c; + } + + static void argverify Argdcl((int, Extsym*)); + static void Pbadret Argdcl((int ftype, Extsym *p)); + + static int +#ifdef KR_headers +readref(pf, e, ftype) + register FILE *pf; + Extsym *e; + int ftype; +#else +readref(register FILE *pf, Extsym *e, int ftype) +#endif +{ + register int c, *t; + int i, nargs, type; + Argtypes *at; + Atype *a, *ae; + + if (ftype > TYSUBR) + return 0; + if ((c = numread(pf, &nargs)) != ' ') { + if (c != ':') + return c == EOF; + /* just a typed external */ + if (e->extstg == STGUNKNOWN) { + at = 0; + goto justsym; + } + if (e->extstg == STGEXT) { + if (e->extype != ftype) + Pbadret(ftype, e); + } + else + Pnotboth(e); + return 0; + } + + tnext = tfirst; + for(i = 0; i < nargs; i++) { + if ((c = numread(pf, &type)) != ' ' + || type >= 500 + || type != TYFTNLEN + 100 && type % 100 > TYSUBR) + return c == EOF; + if (tnext >= tlast) + trealloc(); + *tnext++ = type; + } + + if (e->extstg == STGUNKNOWN) { + save_at: + at = (Argtypes *) + gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1); + at->dnargs = at->nargs = nargs; + at->changes = 0; + t = tfirst; + a = at->atypes; + for(ae = a + nargs; a < ae; a++) { + a->type = *t++; + a->cp = 0; + } + justsym: + e->extstg = STGEXT; + e->extype = ftype; + e->arginfo = at; + } + else if (e->extstg != STGEXT) { + Pnotboth(e); + } + else if (!e->arginfo) { + if (e->extype != ftype) + Pbadret(ftype, e); + else + goto save_at; + } + else + argverify(ftype, e); + return 0; + } + + static int +#ifdef KR_headers +comlen(pf) + register FILE *pf; +#else +comlen(register FILE *pf) +#endif +{ + register int c; + register char *s, *se; + char buf[128], cbuf[128]; + int refread; + long L; + Extsym *e; + + if ((c = getc(pf)) == EOF) + return 1; + if (c == ' ') { + refread = 0; + s = "comlen "; + } + else if (c == ':') { + refread = 1; + s = "ref: "; + } + else { + ret0: + if (c == '*') + ungetc(c,pf); + return 0; + } + while(*s) { + if ((c = getc(pf)) == EOF) + return 1; + if (c != *s++) + goto ret0; + } + s = buf; + se = buf + sizeof(buf) - 1; + for(;;) { + if ((c = getc(pf)) == EOF) + return 1; + if (c == ' ') + break; + if (s >= se || Pct[c] != P_anum) + goto ret0; + *s++ = c; + } + *s-- = 0; + if (s <= buf || *s != '_') + return 0; + strcpy(cbuf,buf); + *s-- = 0; + if (*s == '_') { + *s-- = 0; + if (s <= buf) + return 0; + } + for(L = 0;;) { + if ((c = getc(pf)) == EOF) + return 1; + if (c == ' ') + break; + if (c < '0' && c > '9') + goto ret0; + L = 10*L + c - '0'; + } + if (!L && !refread) + return 0; + e = mkext1(buf, cbuf); + if (refread) + return readref(pf, e, (int)L); + if (e->extstg == STGUNKNOWN) { + e->extstg = STGCOMMON; + e->maxleng = L; + } + else if (e->extstg != STGCOMMON) + Pnotboth(e); + else if (e->maxleng != L) { + fprintf(stderr, + "incompatible lengths for common block %s (line %ld of %s)\n", + buf, Plineno, Pfname); + if (e->maxleng < L) + e->maxleng = L; + } + return 0; + } + + static int +#ifdef KR_headers +Ptoken(pf, canend) + FILE *pf; + int canend; +#else +Ptoken(FILE *pf, int canend) +#endif +{ + register int c; + register char *s, *se; + + top: + for(;;) { + c = getc(pf); + if (c == EOF) { + if (canend) + return 0; + goto badeof; + } + if (Pct[c] != P_space) + break; + if (c == '\n') + Plineno++; + } + switch(Pct[c]) { + case P_anum: + if (c == '_') + badchar(c); + s = Ptok; + se = s + sizeof(Ptok) - 1; + do { + if (s < se) + *s++ = c; + if ((c = getc(pf)) == EOF) { + badeof: + fprintf(stderr, + "unexpected end of file in %s\n", + Pfname); + exit(2); + } + } + while(Pct[c] == P_anum); + ungetc(c,pf); + *s = 0; + return P_anum; + + case P_delim: + return c; + + case P_slash: + if ((c = getc(pf)) != '*') { + if (c == EOF) + goto badeof; + badchar('/'); + } + if (canend && comlen(pf)) + goto badeof; + for(;;) { + while((c = getc(pf)) != '*') { + if (c == EOF) + goto badeof; + if (c == '\n') + Plineno++; + } + slashseek: + switch(getc(pf)) { + case '/': + goto top; + case EOF: + goto badeof; + case '*': + goto slashseek; + } + } + default: + badchar(c); + } + /* NOT REACHED */ + return 0; + } + + static int +Pftype(Void) +{ + switch(Ptok[0]) { + case 'C': + if (!strcmp(Ptok+1, "_f")) + return TYCOMPLEX; + break; + case 'E': + if (!strcmp(Ptok+1, "_f")) { + /* TYREAL under forcedouble */ + checkreal(1); + return TYREAL; + } + break; + case 'H': + if (!strcmp(Ptok+1, "_f")) + return TYCHAR; + break; + case 'Z': + if (!strcmp(Ptok+1, "_f")) + return TYDCOMPLEX; + break; + case 'd': + if (!strcmp(Ptok+1, "oublereal")) + return TYDREAL; + break; + case 'i': + if (!strcmp(Ptok+1, "nt")) + return TYSUBR; + if (!strcmp(Ptok+1, "nteger")) + return TYLONG; + if (!strcmp(Ptok+1, "nteger1")) + return TYINT1; + break; + case 'l': + if (!strcmp(Ptok+1, "ogical")) { + checklogical(1); + return TYLOGICAL; + } + if (!strcmp(Ptok+1, "ogical1")) + return TYLOGICAL1; +#ifdef TYQUAD + if (!strcmp(Ptok+1, "ongint")) + return TYQUAD; +#endif + break; + case 'r': + if (!strcmp(Ptok+1, "eal")) { + checkreal(0); + return TYREAL; + } + break; + case 's': + if (!strcmp(Ptok+1, "hortint")) + return TYSHORT; + if (!strcmp(Ptok+1, "hortlogical")) { + checklogical(0); + return TYLOGICAL2; + } + break; + } + bad_type(); + /* NOT REACHED */ + return 0; + } + + static void +#ifdef KR_headers +wanted(i, what) + int i; + char *what; +#else +wanted(int i, char *what) +#endif +{ + if (i != P_anum) { + Ptok[0] = i; + Ptok[1] = 0; + } + fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n", + what, Ptok, Plineno, Pfname); + exit(2); + } + + static int +#ifdef KR_headers +Ptype(pf) + FILE *pf; +#else +Ptype(FILE *pf) +#endif +{ + int i, rv; + + i = Ptoken(pf,0); + if (i == ')') + return 0; + if (i != P_anum) + badchar(i); + + rv = 0; + switch(Ptok[0]) { + case 'C': + if (!strcmp(Ptok+1, "_fp")) + rv = TYCOMPLEX+200; + break; + case 'D': + if (!strcmp(Ptok+1, "_fp")) + rv = TYDREAL+200; + break; + case 'E': + case 'R': + if (!strcmp(Ptok+1, "_fp")) + rv = TYREAL+200; + break; + case 'H': + if (!strcmp(Ptok+1, "_fp")) + rv = TYCHAR+200; + break; + case 'I': + if (!strcmp(Ptok+1, "_fp")) + rv = TYLONG+200; + else if (!strcmp(Ptok+1, "1_fp")) + rv = TYINT1+200; +#ifdef TYQUAD + else if (!strcmp(Ptok+1, "8_fp")) + rv = TYQUAD+200; +#endif + break; + case 'J': + if (!strcmp(Ptok+1, "_fp")) + rv = TYSHORT+200; + break; + case 'K': + checklogical(0); + goto Logical; + case 'L': + checklogical(1); + Logical: + if (!strcmp(Ptok+1, "_fp")) + rv = TYLOGICAL+200; + else if (!strcmp(Ptok+1, "1_fp")) + rv = TYLOGICAL1+200; + else if (!strcmp(Ptok+1, "2_fp")) + rv = TYLOGICAL2+200; + break; + case 'S': + if (!strcmp(Ptok+1, "_fp")) + rv = TYSUBR+200; + break; + case 'U': + if (!strcmp(Ptok+1, "_fp")) + rv = TYUNKNOWN+300; + break; + case 'Z': + if (!strcmp(Ptok+1, "_fp")) + rv = TYDCOMPLEX+200; + break; + case 'c': + if (!strcmp(Ptok+1, "har")) + rv = TYCHAR; + else if (!strcmp(Ptok+1, "omplex")) + rv = TYCOMPLEX; + break; + case 'd': + if (!strcmp(Ptok+1, "oublereal")) + rv = TYDREAL; + else if (!strcmp(Ptok+1, "oublecomplex")) + rv = TYDCOMPLEX; + break; + case 'f': + if (!strcmp(Ptok+1, "tnlen")) + rv = TYFTNLEN+100; + break; + case 'i': + if (!strncmp(Ptok+1, "nteger", 6)) { + if (!Ptok[7]) + rv = TYLONG; + else if (Ptok[7] == '1' && !Ptok[8]) + rv = TYINT1; + } + break; + case 'l': + if (!strncmp(Ptok+1, "ogical", 6)) { + if (!Ptok[7]) { + checklogical(1); + rv = TYLOGICAL; + } + else if (Ptok[7] == '1' && !Ptok[8]) + rv = TYLOGICAL1; + } +#ifdef TYQUAD + else if (!strcmp(Ptok+1,"ongint")) + rv = TYQUAD; +#endif + break; + case 'r': + if (!strcmp(Ptok+1, "eal")) + rv = TYREAL; + break; + case 's': + if (!strcmp(Ptok+1, "hortint")) + rv = TYSHORT; + else if (!strcmp(Ptok+1, "hortlogical")) { + checklogical(0); + rv = TYLOGICAL2; + } + break; + case 'v': + if (tnext == tfirst && !strcmp(Ptok+1, "oid")) { + if ((i = Ptoken(pf,0)) != /*(*/ ')') + wanted(i, /*(*/ "\")\""); + return 0; + } + } + if (!rv) + bad_type(); + if (rv < 100 && (i = Ptoken(pf,0)) != '*') + wanted(i, "\"*\""); + if ((i = Ptoken(pf,0)) == P_anum) + i = Ptoken(pf,0); /* skip variable name */ + switch(i) { + case ')': + ungetc(i,pf); + break; + case ',': + break; + default: + wanted(i, "\",\" or \")\""); + } + return rv; + } + + static char * +trimunder(Void) +{ + register char *s; + register int n; + static char buf[128]; + + s = Ptok + strlen(Ptok) - 1; + if (*s != '_') { + fprintf(stderr, + "warning: %s does not end in _ (line %ld of %s)\n", + Ptok, Plineno, Pfname); + return Ptok; + } + if (s[-1] == '_') + s--; + strncpy(buf, Ptok, n = s - Ptok); + buf[n] = 0; + return buf; + } + + static void +#ifdef KR_headers +Pbadmsg(msg, p) + char *msg; + Extsym *p; +#else +Pbadmsg(char *msg, Extsym *p) +#endif +{ + Pbad++; + fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg, + p->fextname, Plineno, Pfname); + p->arginfo->nargs = -1; + } + + static void +#ifdef KR_headers +Pbadret(ftype, p) + int ftype; + Extsym *p; +#else +Pbadret(int ftype, Extsym *p) +#endif +{ + char buf1[32], buf2[32]; + + Pbadmsg("inconsistent types",p); + fprintf(stderr, "here %s, previously %s\n", + Argtype(ftype+200,buf1), + Argtype(p->extype+200,buf2)); + } + + static void +#ifdef KR_headers +argverify(ftype, p) + int ftype; + Extsym *p; +#else +argverify(int ftype, Extsym *p) +#endif +{ + Argtypes *at; + register Atype *aty; + int i, j, k; + register int *t, *te; + char buf1[32], buf2[32]; + + at = p->arginfo; + if (at->nargs < 0) + return; + if (p->extype != ftype) { + Pbadret(ftype, p); + return; + } + t = tfirst; + te = tnext; + i = te - t; + if (at->nargs != i) { + j = at->nargs; + Pbadmsg("differing numbers of arguments",p); + fprintf(stderr, "here %d, previously %d\n", + i, j); + return; + } + for(aty = at->atypes; t < te; t++, aty++) { + if (*t == aty->type) + continue; + j = aty->type; + k = *t; + if (k >= 300 || k == j) + continue; + if (j >= 300) { + if (k >= 200) { + if (k == TYUNKNOWN + 200) + continue; + if (j % 100 != k - 200 + && k != TYSUBR + 200 + && j != TYUNKNOWN + 300 + && !type_fixup(at,aty,k)) + goto badtypes; + } + else if (j % 100 % TYSUBR != k % TYSUBR + && !type_fixup(at,aty,k)) + goto badtypes; + } + else if (k < 200 || j < 200) + goto badtypes; + else if (k == TYUNKNOWN+200) + continue; + else if (j != TYUNKNOWN+200) + { + badtypes: + Pbadmsg("differing calling sequences",p); + i = t - tfirst + 1; + fprintf(stderr, + "arg %d: here %s, prevously %s\n", + i, Argtype(k,buf1), Argtype(j,buf2)); + return; + } + /* We've subsequently learned the right type, + as in the call on zoo below... + + subroutine foo(x, zap) + external zap + call goo(zap) + x = zap(3) + call zoo(zap) + end + */ + aty->type = k; + at->changes = 1; + } + } + + static void +#ifdef KR_headers +newarg(ftype, p) + int ftype; + Extsym *p; +#else +newarg(int ftype, Extsym *p) +#endif +{ + Argtypes *at; + register Atype *aty; + register int *t, *te; + int i, k; + + if (p->extstg == STGCOMMON) { + Pnotboth(p); + return; + } + p->extstg = STGEXT; + p->extype = ftype; + p->exproto = 1; + t = tfirst; + te = tnext; + i = te - t; + k = sizeof(Argtypes) + (i-1)*sizeof(Atype); + at = p->arginfo = (Argtypes *)gmem(k,1); + at->dnargs = at->nargs = i; + at->defined = at->changes = 0; + for(aty = at->atypes; t < te; aty++) { + aty->type = *t++; + aty->cp = 0; + } + } + + static int +#ifdef KR_headers +Pfile(fname) + char *fname; +#else +Pfile(char *fname) +#endif +{ + char *s; + int ftype, i; + FILE *pf; + Extsym *p; + + for(s = fname; *s; s++); + if (s - fname < 2 + || s[-2] != '.' + || (s[-1] != 'P' && s[-1] != 'p')) + return 0; + + if (!(pf = fopen(fname, textread))) { + fprintf(stderr, "can't open %s\n", fname); + exit(2); + } + Pfname = fname; + Plineno = 1; + if (!Pct[' ']) { + for(s = " \t\n\r\v\f"; *s; s++) + Pct[*s] = P_space; + for(s = "*,();"; *s; s++) + Pct[*s] = P_delim; + for(i = '0'; i <= '9'; i++) + Pct[i] = P_anum; + for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++) + Pct[i] = Pct[i+'A'-'a'] = P_anum; + Pct['_'] = P_anum; + Pct['/'] = P_slash; + } + + for(;;) { + if (!(i = Ptoken(pf,1))) + break; + if (i != P_anum + || !strcmp(Ptok, "extern") && (i = Ptoken(pf,0)) != P_anum) + badchar(i); + ftype = Pftype(); + getname: + if ((i = Ptoken(pf,0)) != P_anum) + badchar(i); + p = mkext1(trimunder(), Ptok); + + if ((i = Ptoken(pf,0)) != '(') + badchar(i); + tnext = tfirst; + while(i = Ptype(pf)) { + if (tnext >= tlast) + trealloc(); + *tnext++ = i; + } + if (p->arginfo) { + argverify(ftype, p); + if (p->arginfo->nargs < 0) + newarg(ftype, p); + } + else + newarg(ftype, p); + p->arginfo->defined = 1; + i = Ptoken(pf,0); + switch(i) { + case ';': + break; + case ',': + goto getname; + default: + wanted(i, "\";\" or \",\""); + } + } + fclose(pf); + return 1; + } + + void +#ifdef KR_headers +read_Pfiles(ffiles) + char **ffiles; +#else +read_Pfiles(char **ffiles) +#endif +{ + char **f1files, **f1files0, *s; + int k; + register Extsym *e, *ee; + register Argtypes *at; + extern int retcode; + + f1files0 = f1files = ffiles; + while(s = *ffiles++) + if (!Pfile(s)) + *f1files++ = s; + if (Pbad) + retcode = 8; + if (tfirst) { + free((char *)tfirst); + /* following should be unnecessary, as we won't be back here */ + tfirst = tnext = tlast = 0; + tmax = 0; + } + *f1files = 0; + if (f1files == f1files0) + f1files[1] = 0; + + k = 0; + ee = nextext; + for (e = extsymtab; e < ee; e++) + if (e->extstg == STGEXT + && (at = e->arginfo)) { + if (at->nargs < 0 || at->changes) + k++; + at->changes = 2; + } + if (k) { + fprintf(diagfile, + "%d prototype%s updated while reading prototypes.\n", k, + k > 1 ? "s" : ""); + } + fflush(diagfile); + } -- cgit