| #include <ctype.h> |
| #include "f2c.h" |
| #include "fio.h" |
| |
| /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ |
| /* marks in namelist input a la the Fortran 8X Draft published in */ |
| /* the May 1989 issue of Fortran Forum. */ |
| |
| |
| extern char *f__fmtbuf; |
| |
| #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> |
| int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), |
| (*l_ungetc)(int,FILE*); |
| #endif |
| |
| #include "fmt.h" |
| #include "lio.h" |
| #include "fp.h" |
| |
| int l_eof; |
| |
| #define isblnk(x) (f__ltab[x+1]&B) |
| #define issep(x) (f__ltab[x+1]&SX) |
| #define isapos(x) (f__ltab[x+1]&AX) |
| #define isexp(x) (f__ltab[x+1]&EX) |
| #define issign(x) (f__ltab[x+1]&SG) |
| #define iswhit(x) (f__ltab[x+1]&WH) |
| #define SX 1 |
| #define B 2 |
| #define AX 4 |
| #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 |
| }; |
| |
| #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); } |
| #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 |
| #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); |
| } |
| 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); |
| } |
| |
| flag f__lquit; |
| 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);} |
| #define GETC(x) (x=(*l_getc)()) |
| #define Ungetc(x,y) (*l_ungetc)(x,y) |
| |
| #ifdef KR_headers |
| l_R(poststar) int poststar; |
| #else |
| l_R(int poststar) |
| #endif |
| { |
| 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; |
| #endif |
| 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 == '.') { |
| 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 (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 (quad_read && (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 |
| #ifdef KR_headers |
| rd_count(ch) register int ch; |
| #else |
| rd_count(register int ch) |
| #endif |
| { |
| 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; |
| } |
| |
| 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')) { |
| 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); |
| } |
| } |
| else |
| f__lcount = 1; |
| while(iswhit(GETC(ch))); |
| Ungetc(ch,f__cf); |
| nml_save = nml_read; |
| nml_read = 0; |
| if (ch = l_R(1)) |
| 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)) |
| 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; |
| #endif |
| nml_read = nml_save; |
| return(0); |
| } |
| l_L(Void) |
| { |
| int ch; |
| 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); |
| } |
| if(ch == '.') GETC(ch); |
| switch(ch) |
| { |
| case 't': |
| case 'T': |
| f__lx=1; |
| break; |
| case 'f': |
| case 'F': |
| 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"); |
| } |
| f__ltype=TYLONG; |
| while(!issep(GETC(ch)) && ch!=EOF); |
| (void) Ungetc(ch, f__cf); |
| return(0); |
| } |
| #define BUFSIZE 128 |
| 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; |
| #ifndef F8X_NML_ELIDE_QUOTES |
| if (nml_read) { |
| 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; |
| } |
| } |
| } |
| 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); |
| } |
| } |
| } |
| #ifdef KR_headers |
| c_le(a) cilist *a; |
| #else |
| c_le(cilist *a) |
| #endif |
| { |
| if(f__init != 1) f_init(); |
| f__init = 3; |
| f__fmtbuf="list io"; |
| if(a->ciunit>=MXUNIT || a->ciunit<0) |
| err(a->cierr,101,"stler"); |
| f__scale=f__recpos=0; |
| f__elist=a; |
| f__curunit = &f__units[a->ciunit]; |
| 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 |
| { |
| #define Ptr ((flex *)ptr) |
| 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) { |
| 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) |
| { |
| case TYINT1: |
| case TYSHORT: |
| case TYLONG: |
| case TYREAL: |
| case TYDREAL: |
| ERR(l_R(0)); |
| break; |
| #ifdef TYQUAD |
| case TYQUAD: |
| quad_read = 1; |
| n = l_R(0); |
| quad_read = 0; |
| ERR(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=f__lx; |
| break; |
| #ifdef Allow_TYQUAD |
| 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++; |
| } |
| return(0); |
| #undef Ptr |
| } |
| #ifdef KR_headers |
| integer s_rsle(a) cilist *a; |
| #else |
| integer s_rsle(cilist *a) |
| #endif |
| { |
| int n; |
| |
| if(n=c_le(a)) return(n); |
| f__reading=1; |
| f__external=1; |
| f__formatted=1; |
| 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); |
| } |