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)) { 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) { (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); Ungetc(ch, f__cf); return(0); }
static int getname(register char *s, int slen) { register char *se = s + slen - 1; register int ch; GETC(ch); if (!(*s++ = Alpha[ch & 0xff])) { if (ch != EOF) ch = 115; errfl(f__elist->cierr, ch, "namelist read"); } while(*s = Alphanum[GETC(ch) & 0xff]) if (s < se) s++; if (ch == EOF) err(f__elist->cierr, EOF, "namelist read"); if (ch > ' ') Ungetc(ch,f__cf); return *s = 0; }
integer do_fio(ftnint *number, char *ptr, ftnlen len) #endif { 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__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); }
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: #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT ERR(l_R(0,1)); break; #endif case TYREAL: case TYDREAL: ERR(l_R(0,0)); break; #ifdef TYQUAD 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; #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++; }
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; #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); } } }
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')) { 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,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; #endif nml_read = nml_save; return(0); }
l_R(int poststar, int reqint) #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 == '.') { #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 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)) { #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT 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; }
int x_rsne(cilist *a) { int ch, got1, k, n, nd, quote, readall; Namelist *nl; static char where[] = "namelist read"; char buf[64]; hashtab *ht; Vardesc *v; dimen *dn, *dn0, *dn1; ftnlen *dims, *dims1; ftnlen b, b0, b1, ex, no, nomax, size, span; ftnint no1, no2, type; char *vaddr; long iva, ivae; dimen dimens[MAXDIM], substr; if (!Alpha['a']) nl_init(); f__reading=1; f__formatted=1; got1 = 0; top: for(;;) switch(GETC(ch)) { case EOF: eof: err(a->ciend,(EOF),where0); case '&': case '$': goto have_amp; #ifndef No_Namelist_Questions case '?': print_ne(a); continue; #endif default: if (ch <= ' ' && ch >= 0) continue; #ifndef No_Namelist_Comments while(GETC(ch) != '\n') if (ch == EOF) goto eof; #else errfl(a->cierr, 115, where0); #endif } have_amp: if (ch = getname(buf,sizeof(buf))) return ch; nl = (Namelist *)a->cifmt; if (strcmp(buf, nl->name)) #ifdef No_Bad_Namelist_Skip errfl(a->cierr, 118, where0); #else { fprintf(stderr, "Skipping namelist \"%s\": seeking namelist \"%s\".\n", buf, nl->name); fflush(stderr); for(;;) switch(GETC(ch)) { case EOF: err(a->ciend, EOF, where0); case '/': case '&': case '$': if (f__external) e_rsle(); else z_rnew(); goto top; case '"': case '\'': quote = ch; more_quoted: while(GETC(ch) != quote) if (ch == EOF) err(a->ciend, EOF, where0); if (GETC(ch) == quote) goto more_quoted; Ungetc(ch,f__cf); default: continue; } } #endif ht = mk_hashtab(nl); if (!ht) errfl(f__elist->cierr, 113, where0); for(;;) { for(;;) switch(GETC(ch)) { case EOF: if (got1) return 0; err(a->ciend, EOF, where0); case '/': case '$': case '&': return 0; default: if (ch <= ' ' && ch >= 0 || ch == ',') continue; Ungetc(ch,f__cf); if (ch = getname(buf,sizeof(buf))) return ch; goto havename; } havename: v = hash(ht,buf); if (!v) errfl(a->cierr, 119, where); while(GETC(ch) <= ' ' && ch >= 0); vaddr = v->addr; type = v->type; if (type < 0) { size = -type; type = TYCHAR; } else size = f__typesize[type]; ivae = size; iva = readall = 0; if (ch == '(' /*)*/ ) { dn = dimens; if (!(dims = v->dims)) { if (type != TYCHAR) errfl(a->cierr, 122, where); if (k = getdimen(&ch, dn, (ftnlen)size, (ftnlen)size, &b)) errfl(a->cierr, k, where); if (ch != ')') errfl(a->cierr, 115, where); b1 = dn->extent; if (--b < 0 || b + b1 > size) return 124; iva += b; size = b1; while(GETC(ch) <= ' ' && ch >= 0); goto scalar; } nd = (int)dims[0]; nomax = span = dims[1]; ivae = iva + size*nomax; colonseen = 0; if (k = getdimen(&ch, dn, size, nomax, &b)) errfl(a->cierr, k, where); no = dn->extent; b0 = dims[2]; dims1 = dims += 3; ex = 1; for(n = 1; n++ < nd; dims++) { if (ch != ',') errfl(a->cierr, 115, where); dn1 = dn + 1; span /= *dims; if (k = getdimen(&ch, dn1, dn->delta**dims, span, &b1)) errfl(a->cierr, k, where); ex *= *dims; b += b1*ex; no *= dn1->extent; dn = dn1; } if (ch != ')') errfl(a->cierr, 115, where); readall = 1 - colonseen; b -= b0; if (b < 0 || b >= nomax) errfl(a->cierr, 125, where); iva += size * b; dims = dims1; while(GETC(ch) <= ' ' && ch >= 0); no1 = 1; dn0 = dimens; if (type == TYCHAR && ch == '(' /*)*/) { if (k = getdimen(&ch, &substr, size, size, &b)) errfl(a->cierr, k, where); if (ch != ')') errfl(a->cierr, 115, where); b1 = substr.extent; if (--b < 0 || b + b1 > size) return 124; iva += b; b0 = size; size = b1; while(GETC(ch) <= ' ' && ch >= 0); if (b1 < b0) goto delta_adj; } if (readall) goto delta_adj; for(; dn0 < dn; dn0++) { if (dn0->extent != *dims++ || dn0->stride != 1) break; no1 *= dn0->extent; } if (dn0 == dimens && dimens[0].stride == 1) { no1 = dimens[0].extent; dn0++; } delta_adj: ex = 0; for(dn1 = dn0; dn1 <= dn; dn1++) ex += (dn1->extent-1) * (dn1->delta *= dn1->stride); for(dn1 = dn; dn1 > dn0; dn1--) { ex -= (dn1->extent - 1) * dn1->delta; dn1->delta -= ex; } } else if (dims = v->dims) { no = no1 = dims[1]; ivae = iva + no*size; } else scalar: no = no1 = 1; if (ch != '=') errfl(a->cierr, 115, where); got1 = nml_read = 1; f__lcount = 0; readloop: for(;;) { if (iva >= ivae || iva < 0) { f__lquit = 1; goto mustend; } else if (iva + no1*size > ivae) no1 = (ivae - iva)/size; f__lquit = 0; if (k = l_read(&no1, vaddr + iva, size, type)) return k; if (f__lquit == 1) return 0; if (readall) { iva += dn0->delta; if (f__lcount > 0) { no2 = (ivae - iva)/size; if (no2 > f__lcount) no2 = f__lcount; if (k = l_read(&no2, vaddr + iva, size, type)) return k; iva += no2 * dn0->delta; } } mustend: GETC(ch); if (readall) if (iva >= ivae) readall = 0; else for(;;) { switch(ch) { case ' ': case '\t': case '\n': GETC(ch); continue; } break; } if (ch == '/' || ch == '$' || ch == '&') { f__lquit = 1; return 0; } else if (f__lquit) { while(ch <= ' ' && ch >= 0) GETC(ch); Ungetc(ch,f__cf); if (!Alpha[ch & 0xff] && ch >= 0) errfl(a->cierr, 125, where); break; } Ungetc(ch,f__cf); if (readall && !Alpha[ch & 0xff]) goto readloop; if ((no -= no1) <= 0) break; for(dn1 = dn0; dn1 <= dn; dn1++) { if (++dn1->curval < dn1->extent) { iva += dn1->delta; goto readloop; } dn1->curval = 0; } break; } } }
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; } 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); } 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; }