diff options
author | Marc Espie <espie@cvs.openbsd.org> | 2004-12-30 17:35:29 +0000 |
---|---|---|
committer | Marc Espie <espie@cvs.openbsd.org> | 2004-12-30 17:35:29 +0000 |
commit | 157d4bd650a3e421c5bac48da7e528af9a6a76e2 (patch) | |
tree | 0379fb2c85e183c3c5669d425b3e42ae4592791b /gnu/lib/libf2c/libI77/lread.c | |
parent | 791194721fec8918406191b62da6dc41f2d690e5 (diff) |
Actual synch with 3.3.5.
Changes in Makefile.bsd-wrapper to avoid prereq.
Fix in lib*/config.h.in to include the right ones and get the correct
definitions.
Bump of shlib_version accordingly.
Diffstat (limited to 'gnu/lib/libf2c/libI77/lread.c')
-rw-r--r-- | gnu/lib/libf2c/libI77/lread.c | 1405 |
1 files changed, 726 insertions, 679 deletions
diff --git a/gnu/lib/libf2c/libI77/lread.c b/gnu/lib/libf2c/libI77/lread.c index d546efcc4e1..b926367b930 100644 --- a/gnu/lib/libf2c/libI77/lread.c +++ b/gnu/lib/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); } |