summaryrefslogtreecommitdiffstats
path: root/contrib/libf2c/libI77/lread.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/libf2c/libI77/lread.c')
-rw-r--r--contrib/libf2c/libI77/lread.c1405
1 files changed, 726 insertions, 679 deletions
diff --git a/contrib/libf2c/libI77/lread.c b/contrib/libf2c/libI77/lread.c
index d546efc..b926367 100644
--- a/contrib/libf2c/libI77/lread.c
+++ b/contrib/libf2c/libI77/lread.c
@@ -13,28 +13,19 @@ extern int f__fmtlen;
#ifdef Allow_TYQUAD
static longint f__llx;
-static int quad_read;
#endif
-#ifdef KR_headers
-extern double atof();
-extern char *malloc(), *realloc();
-int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
-#else
#undef abs
#undef min
#undef max
#include <stdlib.h>
-#endif
#include "fmt.h"
#include "lio.h"
#include "fp.h"
-#ifndef KR_headers
-int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
- (*l_ungetc)(int,FILE*);
-#endif
+int (*f__lioproc) (ftnint *, char *, ftnlen, ftnint), (*l_getc) (void),
+ (*l_ungetc) (int, FILE *);
int l_eof;
@@ -50,749 +41,805 @@ int l_eof;
#define EX 8
#define SG 16
#define WH 32
-char f__ltab[128+1] = { /* offset one for EOF */
- 0,
- 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+char f__ltab[128 + 1] = { /* offset one for EOF */
+ 0,
+ 0, 0, AX, 0, 0, 0, 0, 0, 0, WH | B, SX | WH, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ SX | B | WH, 0, AX, 0, 0, 0, 0, AX, 0, 0, 0, SG, SX, SG, 0, SX,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ AX, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
};
#ifdef ungetc
- static int
-#ifdef KR_headers
-un_getc(x,f__cf) int x; FILE *f__cf;
-#else
-un_getc(int x, FILE *f__cf)
-#endif
-{ return ungetc(x,f__cf); }
+static int
+un_getc (int x, FILE * f__cf)
+{
+ return ungetc (x, f__cf);
+}
#else
#define un_getc ungetc
-#ifdef KR_headers
- extern int ungetc();
-#else
-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
-#endif
+extern int ungetc (int, FILE *); /* for systems with a buggy stdio.h */
#endif
-t_getc(Void)
-{ int ch;
- if(f__curunit->uend) return(EOF);
- if((ch=getc(f__cf))!=EOF) return(ch);
- if(feof(f__cf))
- f__curunit->uend = l_eof = 1;
- return(EOF);
+int
+t_getc (void)
+{
+ int ch;
+ if (f__curunit->uend)
+ return (EOF);
+ if ((ch = getc (f__cf)) != EOF)
+ return (ch);
+ if (feof (f__cf))
+ f__curunit->uend = l_eof = 1;
+ return (EOF);
}
-integer e_rsle(Void)
+
+integer
+e_rsle (void)
{
- int ch;
- f__init = 1;
- if(f__curunit->uend) return(0);
- while((ch=t_getc())!='\n')
- if (ch == EOF) {
- if(feof(f__cf))
- f__curunit->uend = l_eof = 1;
- return EOF;
- }
- return(0);
+ int ch;
+ f__init = 1;
+ if (f__curunit->uend)
+ return (0);
+ while ((ch = t_getc ()) != '\n')
+ if (ch == EOF)
+ {
+ if (feof (f__cf))
+ f__curunit->uend = l_eof = 1;
+ return EOF;
+ }
+ return (0);
}
flag f__lquit;
-int f__lcount,f__ltype,nml_read;
+int f__lcount, f__ltype, nml_read;
char *f__lchar;
-double f__lx,f__ly;
-#define ERR(x) if(n=(x)) {f__init &= ~2; return(n);}
+double f__lx, f__ly;
+#define ERR(x) if((n=(x))) {f__init &= ~2; return(n);}
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)
- static int
-#ifdef KR_headers
-l_R(poststar, reqint) int poststar, reqint;
-#else
-l_R(int poststar, int reqint)
-#endif
+static int
+l_R (int poststar, int reqint)
{
- char s[FMAX+EXPMAXDIGS+4];
- register int ch;
- register char *sp, *spe, *sp1;
- long e, exp;
- int havenum, havestar, se;
-
- if (!poststar) {
- if (f__lcount > 0)
- return(0);
- f__lcount = 1;
- }
+ char s[FMAX + EXPMAXDIGS + 4];
+ register int ch;
+ register char *sp, *spe, *sp1;
+ long e, exp;
+ int havenum, havestar, se;
+
+ if (!poststar)
+ {
+ if (f__lcount > 0)
+ return (0);
+ f__lcount = 1;
+ }
#ifdef Allow_TYQUAD
- f__llx = 0;
+ f__llx = 0;
#endif
- f__ltype = 0;
- exp = 0;
- havestar = 0;
+ f__ltype = 0;
+ exp = 0;
+ havestar = 0;
retry:
- sp1 = sp = s;
- spe = sp + FMAX;
- havenum = 0;
-
- switch(GETC(ch)) {
- case '-': *sp++ = ch; sp1++; spe++;
- case '+':
- GETC(ch);
- }
- while(ch == '0') {
- ++havenum;
- GETC(ch);
- }
- while(isdigit(ch)) {
- if (sp < spe) *sp++ = ch;
- else ++exp;
- GETC(ch);
- }
- if (ch == '*' && !poststar) {
- if (sp == sp1 || exp || *s == '-') {
- errfl(f__elist->cierr,112,"bad repetition count");
- }
- poststar = havestar = 1;
- *sp = 0;
- f__lcount = atoi(s);
- goto retry;
- }
- if (ch == '.') {
+ sp1 = sp = s;
+ spe = sp + FMAX;
+ havenum = 0;
+
+ switch (GETC (ch))
+ {
+ case '-':
+ *sp++ = ch;
+ sp1++;
+ spe++;
+ case '+':
+ GETC (ch);
+ }
+ while (ch == '0')
+ {
+ ++havenum;
+ GETC (ch);
+ }
+ while (isdigit (ch))
+ {
+ if (sp < spe)
+ *sp++ = ch;
+ else
+ ++exp;
+ GETC (ch);
+ }
+ if (ch == '*' && !poststar)
+ {
+ if (sp == sp1 || exp || *s == '-')
+ {
+ errfl (f__elist->cierr, 112, "bad repetition count");
+ }
+ poststar = havestar = 1;
+ *sp = 0;
+ f__lcount = atoi (s);
+ goto retry;
+ }
+ if (ch == '.')
+ {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
- if (reqint)
- errfl(f__elist->cierr,115,"invalid integer");
+ if (reqint)
+ errfl (f__elist->cierr, 115, "invalid integer");
#endif
- GETC(ch);
- if (sp == sp1)
- while(ch == '0') {
- ++havenum;
- --exp;
- GETC(ch);
- }
- while(isdigit(ch)) {
- if (sp < spe)
- { *sp++ = ch; --exp; }
- GETC(ch);
- }
- }
- havenum += sp - sp1;
- se = 0;
- if (issign(ch))
- goto signonly;
- if (havenum && isexp(ch)) {
+ GETC (ch);
+ if (sp == sp1)
+ while (ch == '0')
+ {
+ ++havenum;
+ --exp;
+ GETC (ch);
+ }
+ while (isdigit (ch))
+ {
+ if (sp < spe)
+ {
+ *sp++ = ch;
+ --exp;
+ }
+ GETC (ch);
+ }
+ }
+ havenum += sp - sp1;
+ se = 0;
+ if (issign (ch))
+ goto signonly;
+ if (havenum && isexp (ch))
+ {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
- if (reqint)
- errfl(f__elist->cierr,115,"invalid integer");
+ if (reqint)
+ errfl (f__elist->cierr, 115, "invalid integer");
#endif
- GETC(ch);
- if (issign(ch)) {
-signonly:
- if (ch == '-') se = 1;
- GETC(ch);
- }
- if (!isdigit(ch)) {
-bad:
- errfl(f__elist->cierr,112,"exponent field");
- }
-
- e = ch - '0';
- while(isdigit(GETC(ch))) {
- e = 10*e + ch - '0';
- if (e > EXPMAX)
- goto bad;
- }
- if (se)
- exp -= e;
- else
- exp += e;
- }
- (void) Ungetc(ch, f__cf);
- if (sp > sp1) {
- ++havenum;
- while(*--sp == '0')
- ++exp;
- if (exp)
- sprintf(sp+1, "e%ld", exp);
- else
- sp[1] = 0;
- f__lx = atof(s);
-#ifdef Allow_TYQUAD
- if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
- /* Assuming 64-bit longint and 32-bit long. */
- if (exp < 0)
- sp += exp;
- if (sp1 <= sp) {
- f__llx = *sp1 - '0';
- while(++sp1 <= sp)
- f__llx = 10*f__llx + (*sp1 - '0');
- }
- while(--exp >= 0)
- f__llx *= 10;
- if (*s == '-')
- f__llx = -f__llx;
- }
-#endif
- }
- else
- f__lx = 0.;
- if (havenum)
- f__ltype = TYLONG;
- else
- switch(ch) {
- case ',':
- case '/':
- break;
- default:
- if (havestar && ( ch == ' '
- ||ch == '\t'
- ||ch == '\n'))
- break;
- if (nml_read > 1) {
- f__lquit = 2;
- return 0;
- }
- errfl(f__elist->cierr,112,"invalid number");
- }
- return 0;
+ GETC (ch);
+ if (issign (ch))
+ {
+ signonly:
+ if (ch == '-')
+ se = 1;
+ GETC (ch);
+ }
+ if (!isdigit (ch))
+ {
+ bad:
+ errfl (f__elist->cierr, 112, "exponent field");
}
- static int
-#ifdef KR_headers
-rd_count(ch) register int ch;
-#else
-rd_count(register int ch)
+ e = ch - '0';
+ while (isdigit (GETC (ch)))
+ {
+ e = 10 * e + ch - '0';
+ if (e > EXPMAX)
+ goto bad;
+ }
+ if (se)
+ exp -= e;
+ else
+ exp += e;
+ }
+ (void) Ungetc (ch, f__cf);
+ if (sp > sp1)
+ {
+ ++havenum;
+ while (*--sp == '0')
+ ++exp;
+ if (exp)
+ sprintf (sp + 1, "e%ld", exp);
+ else
+ sp[1] = 0;
+ f__lx = atof (s);
+#ifdef Allow_TYQUAD
+ if (reqint & 2 && (se = sp - sp1 + exp) > 14 && se < 20)
+ {
+ /* Assuming 64-bit longint and 32-bit long. */
+ if (exp < 0)
+ sp += exp;
+ if (sp1 <= sp)
+ {
+ f__llx = *sp1 - '0';
+ while (++sp1 <= sp)
+ f__llx = 10 * f__llx + (*sp1 - '0');
+ }
+ while (--exp >= 0)
+ f__llx *= 10;
+ if (*s == '-')
+ f__llx = -f__llx;
+ }
#endif
+ }
+ else
+ f__lx = 0.;
+ if (havenum)
+ f__ltype = TYLONG;
+ else
+ switch (ch)
+ {
+ case ',':
+ case '/':
+ break;
+ default:
+ if (havestar && (ch == ' ' || ch == '\t' || ch == '\n'))
+ break;
+ if (nml_read > 1)
+ {
+ f__lquit = 2;
+ return 0;
+ }
+ errfl (f__elist->cierr, 112, "invalid number");
+ }
+ return 0;
+}
+
+static int
+rd_count (register int ch)
{
- if (ch < '0' || ch > '9')
- return 1;
- f__lcount = ch - '0';
- while(GETC(ch) >= '0' && ch <= '9')
- f__lcount = 10*f__lcount + ch - '0';
- Ungetc(ch,f__cf);
- return f__lcount <= 0;
- }
+ if (ch < '0' || ch > '9')
+ return 1;
+ f__lcount = ch - '0';
+ while (GETC (ch) >= '0' && ch <= '9')
+ f__lcount = 10 * f__lcount + ch - '0';
+ Ungetc (ch, f__cf);
+ return f__lcount <= 0;
+}
- static int
-l_C(Void)
-{ int ch, nml_save;
- double lz;
- if(f__lcount>0) return(0);
- f__ltype=0;
- GETC(ch);
- if(ch!='(')
+static int
+l_C (void)
+{
+ int ch, nml_save;
+ double lz;
+ if (f__lcount > 0)
+ return (0);
+ f__ltype = 0;
+ GETC (ch);
+ if (ch != '(')
+ {
+ if (nml_read > 1 && (ch < '0' || ch > '9'))
{
- if (nml_read > 1 && (ch < '0' || ch > '9')) {
- Ungetc(ch,f__cf);
- f__lquit = 2;
- return 0;
- }
- if (rd_count(ch))
- if(!f__cf || !feof(f__cf))
- errfl(f__elist->cierr,112,"complex format");
- else
- err(f__elist->cierr,(EOF),"lread");
- if(GETC(ch)!='*')
- {
- if(!f__cf || !feof(f__cf))
- errfl(f__elist->cierr,112,"no star");
- else
- err(f__elist->cierr,(EOF),"lread");
- }
- if(GETC(ch)!='(')
- { Ungetc(ch,f__cf);
- return(0);
- }
+ Ungetc (ch, f__cf);
+ f__lquit = 2;
+ return 0;
}
- else
- f__lcount = 1;
- while(iswhit(GETC(ch)));
- Ungetc(ch,f__cf);
- nml_save = nml_read;
- nml_read = 0;
- if (ch = l_R(1,0))
- return ch;
- if (!f__ltype)
- errfl(f__elist->cierr,112,"no real part");
- lz = f__lx;
- while(iswhit(GETC(ch)));
- if(ch!=',')
- { (void) Ungetc(ch,f__cf);
- errfl(f__elist->cierr,112,"no comma");
+ if (rd_count (ch))
+ {
+ if (!f__cf || !feof (f__cf))
+ errfl (f__elist->cierr, 112, "complex format");
+ else
+ err (f__elist->cierr, (EOF), "lread");
+ }
+ if (GETC (ch) != '*')
+ {
+ if (!f__cf || !feof (f__cf))
+ errfl (f__elist->cierr, 112, "no star");
+ else
+ err (f__elist->cierr, (EOF), "lread");
}
- while(iswhit(GETC(ch)));
- (void) Ungetc(ch,f__cf);
- if (ch = l_R(1,0))
- return ch;
- if (!f__ltype)
- errfl(f__elist->cierr,112,"no imaginary part");
- while(iswhit(GETC(ch)));
- if(ch!=')') errfl(f__elist->cierr,112,"no )");
- f__ly = f__lx;
- f__lx = lz;
+ if (GETC (ch) != '(')
+ {
+ Ungetc (ch, f__cf);
+ return (0);
+ }
+ }
+ else
+ f__lcount = 1;
+ while (iswhit (GETC (ch)));
+ Ungetc (ch, f__cf);
+ nml_save = nml_read;
+ nml_read = 0;
+ if ((ch = l_R (1, 0)))
+ return ch;
+ if (!f__ltype)
+ errfl (f__elist->cierr, 112, "no real part");
+ lz = f__lx;
+ while (iswhit (GETC (ch)));
+ if (ch != ',')
+ {
+ (void) Ungetc (ch, f__cf);
+ errfl (f__elist->cierr, 112, "no comma");
+ }
+ while (iswhit (GETC (ch)));
+ (void) Ungetc (ch, f__cf);
+ if ((ch = l_R (1, 0)))
+ return ch;
+ if (!f__ltype)
+ errfl (f__elist->cierr, 112, "no imaginary part");
+ while (iswhit (GETC (ch)));
+ if (ch != ')')
+ errfl (f__elist->cierr, 112, "no )");
+ f__ly = f__lx;
+ f__lx = lz;
#ifdef Allow_TYQUAD
- f__llx = 0;
+ f__llx = 0;
#endif
- nml_read = nml_save;
- return(0);
+ nml_read = nml_save;
+ return (0);
}
- static char nmLbuf[256], *nmL_next;
- static int (*nmL_getc_save)(Void);
-#ifdef KR_headers
- static int (*nmL_ungetc_save)(/* int, FILE* */);
-#else
- static int (*nmL_ungetc_save)(int, FILE*);
-#endif
+static char nmLbuf[256], *nmL_next;
+static int (*nmL_getc_save) (void);
+static int (*nmL_ungetc_save) (int, FILE *);
- static int
-nmL_getc(Void)
+static int
+nmL_getc (void)
{
- int rv;
- if (rv = *nmL_next++)
- return rv;
- l_getc = nmL_getc_save;
- l_ungetc = nmL_ungetc_save;
- return (*l_getc)();
- }
+ int rv;
+ if ((rv = *nmL_next++))
+ return rv;
+ l_getc = nmL_getc_save;
+ l_ungetc = nmL_ungetc_save;
+ return (*l_getc) ();
+}
- static int
-#ifdef KR_headers
-nmL_ungetc(x, f) int x; FILE *f;
-#else
-nmL_ungetc(int x, FILE *f)
-#endif
+static int
+nmL_ungetc (int x, FILE * f)
{
- f = f; /* banish non-use warning */
- return *--nmL_next = x;
- }
+ f = f; /* banish non-use warning */
+ return *--nmL_next = x;
+}
- static int
-#ifdef KR_headers
-Lfinish(ch, dot, rvp) int ch, dot, *rvp;
-#else
-Lfinish(int ch, int dot, int *rvp)
-#endif
+static int
+Lfinish (int ch, int dot, int *rvp)
{
- char *s, *se;
- static char what[] = "namelist input";
-
- s = nmLbuf + 2;
- se = nmLbuf + sizeof(nmLbuf) - 1;
- *s++ = ch;
- while(!issep(GETC(ch)) && ch!=EOF) {
- if (s >= se) {
- nmLbuf_ovfl:
- return *rvp = err__fl(f__elist->cierr,131,what);
- }
- *s++ = ch;
- if (ch != '=')
- continue;
- if (dot)
- return *rvp = err__fl(f__elist->cierr,112,what);
- got_eq:
- *s = 0;
- nmL_getc_save = l_getc;
- l_getc = nmL_getc;
- nmL_ungetc_save = l_ungetc;
- l_ungetc = nmL_ungetc;
- nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
- *rvp = f__lcount = 0;
- return 1;
- }
- if (dot)
- goto done;
- for(;;) {
- if (s >= se)
- goto nmLbuf_ovfl;
- *s++ = ch;
- if (!isblnk(ch))
- break;
- if (GETC(ch) == EOF)
- goto done;
- }
- if (ch == '=')
- goto got_eq;
- done:
- Ungetc(ch, f__cf);
- return 0;
+ char *s, *se;
+ static char what[] = "namelist input";
+
+ s = nmLbuf + 2;
+ se = nmLbuf + sizeof (nmLbuf) - 1;
+ *s++ = ch;
+ while (!issep (GETC (ch)) && ch != EOF)
+ {
+ if (s >= se)
+ {
+ nmLbuf_ovfl:
+ return *rvp = err__fl (f__elist->cierr, 131, what);
}
+ *s++ = ch;
+ if (ch != '=')
+ continue;
+ if (dot)
+ return *rvp = err__fl (f__elist->cierr, 112, what);
+ got_eq:
+ *s = 0;
+ nmL_getc_save = l_getc;
+ l_getc = nmL_getc;
+ nmL_ungetc_save = l_ungetc;
+ l_ungetc = nmL_ungetc;
+ nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
+ *rvp = f__lcount = 0;
+ return 1;
+ }
+ if (dot)
+ goto done;
+ for (;;)
+ {
+ if (s >= se)
+ goto nmLbuf_ovfl;
+ *s++ = ch;
+ if (!isblnk (ch))
+ break;
+ if (GETC (ch) == EOF)
+ goto done;
+ }
+ if (ch == '=')
+ goto got_eq;
+done:
+ Ungetc (ch, f__cf);
+ return 0;
+}
- static int
-l_L(Void)
+static int
+l_L (void)
{
- int ch, rv, sawdot;
- if(f__lcount>0)
- return(0);
- f__lcount = 1;
- f__ltype=0;
- GETC(ch);
- if(isdigit(ch))
+ int ch, rv, sawdot;
+ if (f__lcount > 0)
+ return (0);
+ f__lcount = 1;
+ f__ltype = 0;
+ GETC (ch);
+ if (isdigit (ch))
+ {
+ rd_count (ch);
+ if (GETC (ch) != '*')
+ {
+ if (!f__cf || !feof (f__cf))
+ errfl (f__elist->cierr, 112, "no star");
+ else
+ err (f__elist->cierr, (EOF), "lread");
+ }
+ GETC (ch);
+ }
+ sawdot = 0;
+ if (ch == '.')
+ {
+ sawdot = 1;
+ GETC (ch);
+ }
+ switch (ch)
+ {
+ case 't':
+ case 'T':
+ if (nml_read && Lfinish (ch, sawdot, &rv))
+ return rv;
+ f__lx = 1;
+ break;
+ case 'f':
+ case 'F':
+ if (nml_read && Lfinish (ch, sawdot, &rv))
+ return rv;
+ f__lx = 0;
+ break;
+ default:
+ if (isblnk (ch) || issep (ch) || ch == EOF)
{
- rd_count(ch);
- if(GETC(ch)!='*')
- if(!f__cf || !feof(f__cf))
- errfl(f__elist->cierr,112,"no star");
- else
- err(f__elist->cierr,(EOF),"lread");
- GETC(ch);
+ (void) Ungetc (ch, f__cf);
+ return (0);
}
- sawdot = 0;
- if(ch == '.') {
- sawdot = 1;
- GETC(ch);
- }
- switch(ch)
+ if (nml_read > 1)
{
- case 't':
- case 'T':
- if (nml_read && Lfinish(ch, sawdot, &rv))
- return rv;
- f__lx=1;
- break;
- case 'f':
- case 'F':
- if (nml_read && Lfinish(ch, sawdot, &rv))
- return rv;
- f__lx=0;
- break;
- default:
- if(isblnk(ch) || issep(ch) || ch==EOF)
- { (void) Ungetc(ch,f__cf);
- return(0);
- }
- if (nml_read > 1) {
- Ungetc(ch,f__cf);
- f__lquit = 2;
- return 0;
- }
- errfl(f__elist->cierr,112,"logical");
+ Ungetc (ch, f__cf);
+ f__lquit = 2;
+ return 0;
}
- f__ltype=TYLONG;
- while(!issep(GETC(ch)) && ch!=EOF);
- (void) Ungetc(ch, f__cf);
- return(0);
+ errfl (f__elist->cierr, 112, "logical");
+ }
+ f__ltype = TYLONG;
+ while (!issep (GETC (ch)) && ch != EOF);
+ (void) Ungetc (ch, f__cf);
+ return (0);
}
#define BUFSIZE 128
- static int
-l_CHAR(Void)
-{ int ch,size,i;
- static char rafail[] = "realloc failure";
- char quote,*p;
- if(f__lcount>0) return(0);
- f__ltype=0;
- if(f__lchar!=NULL) free(f__lchar);
- size=BUFSIZE;
- p=f__lchar = (char *)malloc((unsigned int)size);
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,"no space");
-
- GETC(ch);
- if(isdigit(ch)) {
- /* allow Fortran 8x-style unquoted string... */
- /* either find a repetition count or the string */
- f__lcount = ch - '0';
- *p++ = ch;
- for(i = 1;;) {
- switch(GETC(ch)) {
- case '*':
- if (f__lcount == 0) {
- f__lcount = 1;
-#ifndef F8X_NML_ELIDE_QUOTES
- if (nml_read)
- goto no_quote;
-#endif
- goto noquote;
- }
- p = f__lchar;
- goto have_lcount;
- case ',':
- case ' ':
- case '\t':
- case '\n':
- case '/':
- Ungetc(ch,f__cf);
- /* no break */
- case EOF:
- f__lcount = 1;
- f__ltype = TYCHAR;
- return *p = 0;
- }
- if (!isdigit(ch)) {
- f__lcount = 1;
+static int
+l_CHAR (void)
+{
+ int ch, size, i;
+ static char rafail[] = "realloc failure";
+ char quote, *p;
+ if (f__lcount > 0)
+ return (0);
+ f__ltype = 0;
+ if (f__lchar != NULL)
+ free (f__lchar);
+ size = BUFSIZE;
+ p = f__lchar = (char *) malloc ((unsigned int) size);
+ if (f__lchar == NULL)
+ errfl (f__elist->cierr, 113, "no space");
+
+ GETC (ch);
+ if (isdigit (ch))
+ {
+ /* allow Fortran 8x-style unquoted string... */
+ /* either find a repetition count or the string */
+ f__lcount = ch - '0';
+ *p++ = ch;
+ for (i = 1;;)
+ {
+ switch (GETC (ch))
+ {
+ case '*':
+ if (f__lcount == 0)
+ {
+ f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
- if (nml_read) {
- no_quote:
- errfl(f__elist->cierr,112,
- "undelimited character string");
- }
+ if (nml_read)
+ goto no_quote;
#endif
- goto noquote;
- }
- *p++ = ch;
- f__lcount = 10*f__lcount + ch - '0';
- if (++i == size) {
- f__lchar = (char *)realloc(f__lchar,
- (unsigned int)(size += BUFSIZE));
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,rafail);
- p = f__lchar + i;
- }
- }
- }
- else (void) Ungetc(ch,f__cf);
- have_lcount:
- if(GETC(ch)=='\'' || ch=='"') quote=ch;
- else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
- Ungetc(ch,f__cf);
- return 0;
+ goto noquote;
}
+ p = f__lchar;
+ goto have_lcount;
+ case ',':
+ case ' ':
+ case '\t':
+ case '\n':
+ case '/':
+ Ungetc (ch, f__cf);
+ /* no break */
+ case EOF:
+ f__lcount = 1;
+ f__ltype = TYCHAR;
+ return *p = 0;
+ }
+ if (!isdigit (ch))
+ {
+ f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
- else if (nml_read > 1) {
- Ungetc(ch,f__cf);
- f__lquit = 2;
- return 0;
- }
-#endif
- else {
- /* Fortran 8x-style unquoted string */
- *p++ = ch;
- for(i = 1;;) {
- switch(GETC(ch)) {
- case ',':
- case ' ':
- case '\t':
- case '\n':
- case '/':
- Ungetc(ch,f__cf);
- /* no break */
- case EOF:
- f__ltype = TYCHAR;
- return *p = 0;
- }
- noquote:
- *p++ = ch;
- if (++i == size) {
- f__lchar = (char *)realloc(f__lchar,
- (unsigned int)(size += BUFSIZE));
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,rafail);
- p = f__lchar + i;
- }
- }
- }
- f__ltype=TYCHAR;
- for(i=0;;)
- { while(GETC(ch)!=quote && ch!='\n'
- && ch!=EOF && ++i<size) *p++ = ch;
- if(i==size)
+ if (nml_read)
{
- newone:
- f__lchar= (char *)realloc(f__lchar,
- (unsigned int)(size += BUFSIZE));
- if(f__lchar == NULL)
- errfl(f__elist->cierr,113,rafail);
- p=f__lchar+i-1;
- *p++ = ch;
- }
- else if(ch==EOF) return(EOF);
- else if(ch=='\n')
- { if(*(p-1) != '\\') continue;
- i--;
- p--;
- if(++i<size) *p++ = ch;
- else goto newone;
- }
- else if(GETC(ch)==quote)
- { if(++i<size) *p++ = ch;
- else goto newone;
- }
- else
- { (void) Ungetc(ch,f__cf);
- *p = 0;
- return(0);
+ no_quote:
+ errfl (f__elist->cierr, 112,
+ "undelimited character string");
}
+#endif
+ goto noquote;
+ }
+ *p++ = ch;
+ f__lcount = 10 * f__lcount + ch - '0';
+ if (++i == size)
+ {
+ f__lchar = (char *) realloc (f__lchar,
+ (unsigned int) (size += BUFSIZE));
+ if (f__lchar == NULL)
+ errfl (f__elist->cierr, 113, rafail);
+ p = f__lchar + i;
+ }
}
-}
-#ifdef KR_headers
-c_le(a) cilist *a;
-#else
-c_le(cilist *a)
+ }
+ else
+ (void) Ungetc (ch, f__cf);
+have_lcount:
+ if (GETC (ch) == '\'' || ch == '"')
+ quote = ch;
+ else if (isblnk (ch) || (issep (ch) && ch != '\n') || ch == EOF)
+ {
+ Ungetc (ch, f__cf);
+ return 0;
+ }
+#ifndef F8X_NML_ELIDE_QUOTES
+ else if (nml_read > 1)
+ {
+ Ungetc (ch, f__cf);
+ f__lquit = 2;
+ return 0;
+ }
#endif
+ else
+ {
+ /* Fortran 8x-style unquoted string */
+ *p++ = ch;
+ for (i = 1;;)
+ {
+ switch (GETC (ch))
+ {
+ case ',':
+ case ' ':
+ case '\t':
+ case '\n':
+ case '/':
+ Ungetc (ch, f__cf);
+ /* no break */
+ case EOF:
+ f__ltype = TYCHAR;
+ return *p = 0;
+ }
+ noquote:
+ *p++ = ch;
+ if (++i == size)
+ {
+ f__lchar = (char *) realloc (f__lchar,
+ (unsigned int) (size += BUFSIZE));
+ if (f__lchar == NULL)
+ errfl (f__elist->cierr, 113, rafail);
+ p = f__lchar + i;
+ }
+ }
+ }
+ f__ltype = TYCHAR;
+ for (i = 0;;)
+ {
+ while (GETC (ch) != quote && ch != '\n' && ch != EOF && ++i < size)
+ *p++ = ch;
+ if (i == size)
+ {
+ newone:
+ f__lchar = (char *) realloc (f__lchar,
+ (unsigned int) (size += BUFSIZE));
+ if (f__lchar == NULL)
+ errfl (f__elist->cierr, 113, rafail);
+ p = f__lchar + i - 1;
+ *p++ = ch;
+ }
+ else if (ch == EOF)
+ return (EOF);
+ else if (ch == '\n')
+ {
+ if (*(p - 1) != '\\')
+ continue;
+ i--;
+ p--;
+ if (++i < size)
+ *p++ = ch;
+ else
+ goto newone;
+ }
+ else if (GETC (ch) == quote)
+ {
+ if (++i < size)
+ *p++ = ch;
+ else
+ goto newone;
+ }
+ else
+ {
+ (void) Ungetc (ch, f__cf);
+ *p = 0;
+ return (0);
+ }
+ }
+}
+
+int
+c_le (cilist * a)
{
- if(f__init != 1) f_init();
- f__init = 3;
- f__fmtbuf="list io";
- f__curunit = &f__units[a->ciunit];
- f__fmtlen=7;
- if(a->ciunit>=MXUNIT || a->ciunit<0)
- err(a->cierr,101,"stler");
- f__scale=f__recpos=0;
- f__elist=a;
- if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
- err(a->cierr,102,"lio");
- f__cf=f__curunit->ufd;
- if(!f__curunit->ufmt) err(a->cierr,103,"lio");
- return(0);
+ if (f__init != 1)
+ f_init ();
+ f__init = 3;
+ f__fmtbuf = "list io";
+ f__curunit = &f__units[a->ciunit];
+ f__fmtlen = 7;
+ if (a->ciunit >= MXUNIT || a->ciunit < 0)
+ err (a->cierr, 101, "stler");
+ f__scale = f__recpos = 0;
+ f__elist = a;
+ if (f__curunit->ufd == NULL && fk_open (SEQ, FMT, a->ciunit))
+ err (a->cierr, 102, "lio");
+ f__cf = f__curunit->ufd;
+ if (!f__curunit->ufmt)
+ err (a->cierr, 103, "lio");
+ return (0);
}
-#ifdef KR_headers
-l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
-#else
-l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
-#endif
+
+int
+l_read (ftnint * number, char *ptr, ftnlen len, ftnint type)
{
#define Ptr ((flex *)ptr)
- int i,n,ch;
- doublereal *yy;
- real *xx;
- for(i=0;i<*number;i++)
+ int i, n, ch;
+ doublereal *yy;
+ real *xx;
+ for (i = 0; i < *number; i++)
+ {
+ if (f__lquit)
+ return (0);
+ if (l_eof)
+ err (f__elist->ciend, EOF, "list in");
+ if (f__lcount == 0)
{
- if(f__lquit) return(0);
- if(l_eof)
- err(f__elist->ciend, EOF, "list in");
- if(f__lcount == 0) {
- f__ltype = 0;
- for(;;) {
- GETC(ch);
- switch(ch) {
- case EOF:
- err(f__elist->ciend,(EOF),"list in");
- case ' ':
- case '\t':
- case '\n':
- continue;
- case '/':
- f__lquit = 1;
- goto loopend;
- case ',':
- f__lcount = 1;
- goto loopend;
- default:
- (void) Ungetc(ch, f__cf);
- goto rddata;
- }
- }
- }
- rddata:
- switch((int)type)
+ f__ltype = 0;
+ for (;;)
+ {
+ GETC (ch);
+ switch (ch)
{
- case TYINT1:
- case TYSHORT:
- case TYLONG:
+ case EOF:
+ err (f__elist->ciend, (EOF), "list in");
+ case ' ':
+ case '\t':
+ case '\n':
+ continue;
+ case '/':
+ f__lquit = 1;
+ goto loopend;
+ case ',':
+ f__lcount = 1;
+ goto loopend;
+ default:
+ (void) Ungetc (ch, f__cf);
+ goto rddata;
+ }
+ }
+ }
+ rddata:
+ switch ((int) type)
+ {
+ case TYINT1:
+ case TYSHORT:
+ case TYLONG:
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
- ERR(l_R(0,1));
- break;
+ ERR (l_R (0, 1));
+ break;
#endif
- case TYREAL:
- case TYDREAL:
- ERR(l_R(0,0));
- break;
+ case TYREAL:
+ case TYDREAL:
+ ERR (l_R (0, 0));
+ break;
#ifdef TYQUAD
- case TYQUAD:
- n = l_R(0,2);
- if (n)
- return n;
- break;
+ case TYQUAD:
+ n = l_R (0, 2);
+ if (n)
+ return n;
+ break;
#endif
- case TYCOMPLEX:
- case TYDCOMPLEX:
- ERR(l_C());
- break;
- case TYLOGICAL1:
- case TYLOGICAL2:
- case TYLOGICAL:
- ERR(l_L());
- break;
- case TYCHAR:
- ERR(l_CHAR());
- break;
- }
- while (GETC(ch) == ' ' || ch == '\t');
- if (ch != ',' || f__lcount > 1)
- Ungetc(ch,f__cf);
- loopend:
- if(f__lquit) return(0);
- if(f__cf && ferror(f__cf)) {
- clearerr(f__cf);
- errfl(f__elist->cierr,errno,"list in");
- }
- if(f__ltype==0) goto bump;
- switch((int)type)
- {
- case TYINT1:
- case TYLOGICAL1:
- Ptr->flchar = (char)f__lx;
- break;
- case TYLOGICAL2:
- case TYSHORT:
- Ptr->flshort = (short)f__lx;
- break;
- case TYLOGICAL:
- case TYLONG:
- Ptr->flint = (ftnint)f__lx;
- break;
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ ERR (l_C ());
+ break;
+ case TYLOGICAL1:
+ case TYLOGICAL2:
+ case TYLOGICAL:
+ ERR (l_L ());
+ break;
+ case TYCHAR:
+ ERR (l_CHAR ());
+ break;
+ }
+ while (GETC (ch) == ' ' || ch == '\t');
+ if (ch != ',' || f__lcount > 1)
+ Ungetc (ch, f__cf);
+ loopend:
+ if (f__lquit)
+ return (0);
+ if (f__cf && ferror (f__cf))
+ {
+ clearerr (f__cf);
+ errfl (f__elist->cierr, errno, "list in");
+ }
+ if (f__ltype == 0)
+ goto bump;
+ switch ((int) type)
+ {
+ case TYINT1:
+ case TYLOGICAL1:
+ Ptr->flchar = (char) f__lx;
+ break;
+ case TYLOGICAL2:
+ case TYSHORT:
+ Ptr->flshort = (short) f__lx;
+ break;
+ case TYLOGICAL:
+ case TYLONG:
+ Ptr->flint = (ftnint) f__lx;
+ break;
#ifdef Allow_TYQUAD
- case TYQUAD:
- if (!(Ptr->fllongint = f__llx))
- Ptr->fllongint = f__lx;
- break;
+ case TYQUAD:
+ if (!(Ptr->fllongint = f__llx))
+ Ptr->fllongint = f__lx;
+ break;
#endif
- case TYREAL:
- Ptr->flreal=f__lx;
- break;
- case TYDREAL:
- Ptr->fldouble=f__lx;
- break;
- case TYCOMPLEX:
- xx=(real *)ptr;
- *xx++ = f__lx;
- *xx = f__ly;
- break;
- case TYDCOMPLEX:
- yy=(doublereal *)ptr;
- *yy++ = f__lx;
- *yy = f__ly;
- break;
- case TYCHAR:
- b_char(f__lchar,ptr,len);
- break;
- }
- bump:
- if(f__lcount>0) f__lcount--;
- ptr += len;
- if (nml_read)
- nml_read++;
+ case TYREAL:
+ Ptr->flreal = f__lx;
+ break;
+ case TYDREAL:
+ Ptr->fldouble = f__lx;
+ break;
+ case TYCOMPLEX:
+ xx = (real *) ptr;
+ *xx++ = f__lx;
+ *xx = f__ly;
+ break;
+ case TYDCOMPLEX:
+ yy = (doublereal *) ptr;
+ *yy++ = f__lx;
+ *yy = f__ly;
+ break;
+ case TYCHAR:
+ b_char (f__lchar, ptr, len);
+ break;
}
- return(0);
+ bump:
+ if (f__lcount > 0)
+ f__lcount--;
+ ptr += len;
+ if (nml_read)
+ nml_read++;
+ }
+ return (0);
#undef Ptr
}
-#ifdef KR_headers
-integer s_rsle(a) cilist *a;
-#else
-integer s_rsle(cilist *a)
-#endif
+
+integer
+s_rsle (cilist * a)
{
- int n;
-
- f__reading=1;
- f__external=1;
- f__formatted=1;
- if(n=c_le(a)) return(n);
- f__lioproc = l_read;
- f__lquit = 0;
- f__lcount = 0;
- l_eof = 0;
- if(f__curunit->uwrt && f__nowreading(f__curunit))
- err(a->cierr,errno,"read start");
- if(f__curunit->uend)
- err(f__elist->ciend,(EOF),"read start");
- l_getc = t_getc;
- l_ungetc = un_getc;
- f__doend = xrd_SL;
- return(0);
+ int n;
+
+ f__reading = 1;
+ f__external = 1;
+ f__formatted = 1;
+ if ((n = c_le (a)))
+ return (n);
+ f__lioproc = l_read;
+ f__lquit = 0;
+ f__lcount = 0;
+ l_eof = 0;
+ if (f__curunit->uwrt && f__nowreading (f__curunit))
+ err (a->cierr, errno, "read start");
+ if (f__curunit->uend)
+ err (f__elist->ciend, (EOF), "read start");
+ l_getc = t_getc;
+ l_ungetc = un_getc;
+ f__doend = xrd_SL;
+ return (0);
}
OpenPOWER on IntegriCloud