![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lread.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / lib / libI77|
Return to lread.c CVS log | Up to [CSRG BSD Unix] / 40BSD / lib / libI77 |
1.1 ! root 1: #include "fio.h" ! 2: #include "fmt.h" ! 3: #include "lio.h" ! 4: #include "ctype.h" ! 5: extern char *fmtbuf; ! 6: extern char *malloc(), *realloc(); ! 7: int (*lioproc)(); ! 8: ! 9: #define isblnk(x) (ltab[x+1]&B) ! 10: #define issep(x) (ltab[x+1]&SX) ! 11: #define isapos(x) (ltab[x+1]&AX) ! 12: #define isexp(x) (ltab[x+1]&EX) ! 13: #define issign(x) (ltab[x+1]&SG) ! 14: #define SX 1 ! 15: #define B 2 ! 16: #define AX 4 ! 17: #define EX 8 ! 18: #define SG 16 ! 19: char ltab[128+1] = { /* offset one for EOF */ ! 20: 0, ! 21: 0,0,AX,0,0,0,0,0,0,0,SX,0,0,0,0,0, ! 22: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 23: SX|B,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, ! 24: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 25: 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, ! 26: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 27: AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, ! 28: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ! 29: }; ! 30: ! 31: char l_comma, l_first; ! 32: t_getc() ! 33: { int ch; ! 34: if(curunit->uend) return(EOF); ! 35: if((ch=getc(cf))!=EOF) return(ch); ! 36: if(feof(cf)) curunit->uend = 1; ! 37: return(EOF); ! 38: } ! 39: e_rsle() ! 40: { ! 41: int ch; ! 42: if(curunit->uend) return(0); ! 43: while((ch=t_getc())!='\n' && ch!=EOF); ! 44: return(0); ! 45: } ! 46: ! 47: flag lquit; ! 48: int lcount,ltype; ! 49: char *lchar; ! 50: double lx,ly; ! 51: #define ERR(x) if(n=(x)) return(n) ! 52: #define GETC(x) (x=t_getc()) ! 53: ! 54: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len; ! 55: { int i,n,ch; ! 56: double *yy; ! 57: float *xx; ! 58: for(i=0;i<*number;i++) ! 59: { ! 60: if(lquit) return(0); ! 61: if(curunit->uend) err(elist->ciend, EOF, "list in") ! 62: if(lcount == 0) { ! 63: ltype = NULL; ! 64: if(!l_first) l_comma = 0; ! 65: else l_first = 0; ! 66: for(;;) { ! 67: GETC(ch); ! 68: switch(ch) { ! 69: case EOF: ! 70: goto loopend; ! 71: case ' ': ! 72: case '\n': ! 73: continue; ! 74: case '/': ! 75: lquit = 1; ! 76: goto loopend; ! 77: case ',': ! 78: if(l_comma) { ! 79: lcount = 1; ! 80: (void) ungetc(ch, cf); ! 81: goto loopend; ! 82: } ! 83: l_comma = 1; ! 84: continue; ! 85: default: ! 86: (void) ungetc(ch, cf); ! 87: goto rddata; ! 88: } ! 89: } ! 90: } ! 91: rddata: ! 92: switch((int)type) ! 93: { ! 94: case TYSHORT: ! 95: case TYLONG: ! 96: case TYREAL: ! 97: case TYDREAL: ! 98: ERR(l_R()); ! 99: break; ! 100: case TYCOMPLEX: ! 101: case TYDCOMPLEX: ! 102: ERR(l_C()); ! 103: break; ! 104: case TYLOGICAL: ! 105: ERR(l_L()); ! 106: break; ! 107: case TYCHAR: ! 108: ERR(l_CHAR()); ! 109: break; ! 110: } ! 111: loopend: ! 112: if(lquit) return(0); ! 113: if(feof(cf)) err(elist->ciend,(EOF),"list in") ! 114: else if(ferror(cf)) ! 115: { clearerr(cf); ! 116: err(elist->cierr,errno,"list in") ! 117: } ! 118: if(ltype==NULL) goto bump; ! 119: switch((int)type) ! 120: { ! 121: case TYSHORT: ! 122: ptr->flshort=lx; ! 123: break; ! 124: case TYLOGICAL: ! 125: case TYLONG: ! 126: ptr->flint=lx; ! 127: break; ! 128: case TYREAL: ! 129: ptr->flreal=lx; ! 130: break; ! 131: case TYDREAL: ! 132: ptr->fldouble=lx; ! 133: break; ! 134: case TYCOMPLEX: ! 135: xx=(float *)ptr; ! 136: *xx++ = lx; ! 137: *xx = ly; ! 138: break; ! 139: case TYDCOMPLEX: ! 140: yy=(double *)ptr; ! 141: *yy++ = lx; ! 142: *yy = ly; ! 143: break; ! 144: case TYCHAR: ! 145: b_char(lchar,(char *)ptr,len); ! 146: break; ! 147: } ! 148: bump: ! 149: if(lcount>0) lcount--; ! 150: ptr = (flex *)((char *)ptr + len); ! 151: } ! 152: return(0); ! 153: } ! 154: l_R() ! 155: { double a,b,c,d; ! 156: int i,ch,sign=0,da,db,dc; ! 157: int poststar = 0; ! 158: a=b=c=d=0; ! 159: da=db=dc=0; ! 160: if(lcount>0) return(0); ! 161: ltype=NULL; ! 162: da=rd_int(&a); ! 163: if(da== -1) sign=da; ! 164: if(GETC(ch)!='*') ! 165: { (void) ungetc(ch,cf); ! 166: db=1; ! 167: b=a; ! 168: a=1; ! 169: } ! 170: else ! 171: db=rd_int(&b); ! 172: if(db > 0) poststar = 1; ! 173: if(GETC(ch)!='.') ! 174: { dc=c=0; ! 175: (void) ungetc(ch,cf); ! 176: } ! 177: else dc=rd_int(&c); ! 178: if(dc > 0) poststar = 1; ! 179: if(isexp(GETC(ch))) db=rd_int(&d); ! 180: else if(issign(ch)) ! 181: { (void) ungetc(ch, cf); ! 182: db = rd_int(&d); ! 183: } ! 184: else ! 185: { (void) ungetc(ch,cf); ! 186: db = 0; ! 187: d=0; ! 188: } ! 189: if(db > 0) poststar = 1; ! 190: lcount=a; ! 191: if(poststar == 0) ! 192: return(0); ! 193: if(db && b<0) ! 194: { sign=1; ! 195: b = -b; ! 196: } ! 197: for(i=0;i<dc;i++) c/=10; ! 198: b=b+c; ! 199: for(i=0;i<d;i++) b *= 10; ! 200: for(i=0;i< -d;i++) b /= 10; ! 201: if(sign) b = -b; ! 202: ltype=TYLONG; ! 203: lx=b; ! 204: return(0); ! 205: } ! 206: rd_int(x) double *x; ! 207: { int ch,sign=0,i; ! 208: double y; ! 209: i=0; ! 210: y=0; ! 211: if(GETC(ch)=='-') sign = -1; ! 212: else if(ch=='+') sign=0; ! 213: else (void) ungetc(ch,cf); ! 214: while(isdigit(GETC(ch))) ! 215: { i++; ! 216: y=10*y+ch-'0'; ! 217: } ! 218: (void) ungetc(ch,cf); ! 219: if(sign) y = -y; ! 220: *x = y; ! 221: return(y!=0?i:sign); ! 222: } ! 223: l_C() ! 224: { int ch; ! 225: if(lcount>0) return(0); ! 226: ltype=NULL; ! 227: GETC(ch); ! 228: if(ch!='(') ! 229: { if(fscanf(cf,"%d",&lcount)!=1) ! 230: if(!feof(cf)) err(elist->cierr,112,"complex format") ! 231: else err(elist->cierr,(EOF),"lread"); ! 232: if(GETC(ch)!='*') ! 233: { (void) ungetc(ch,cf); ! 234: if(!feof(cf)) err(elist->cierr,112,"no star") ! 235: else err(elist->cierr,(EOF),"lread"); ! 236: } ! 237: if(GETC(ch)!='(') ! 238: { (void) ungetc(ch,cf); ! 239: return(0); ! 240: } ! 241: } ! 242: lcount = 1; ! 243: ltype=TYLONG; ! 244: (void) fscanf(cf,"%lf",&lx); ! 245: while(isblnk(GETC(ch)) || (ch == '\n')); ! 246: if(ch!=',') ! 247: { (void) ungetc(ch,cf); ! 248: err(elist->cierr,112,"no comma"); ! 249: } ! 250: while(isblnk(GETC(ch))); ! 251: (void) ungetc(ch,cf); ! 252: (void) fscanf(cf,"%lf",&ly); ! 253: while(isblnk(GETC(ch))); ! 254: if(ch!=')') err(elist->cierr,112,"no )"); ! 255: while(isblnk(GETC(ch))); ! 256: if(ch != '\n') (void) ungetc(ch,cf); ! 257: return(0); ! 258: } ! 259: l_L() ! 260: { ! 261: int ch; ! 262: if(lcount>0) return(0); ! 263: ltype=NULL; ! 264: GETC(ch); ! 265: if(isdigit(ch)) ! 266: { (void) ungetc(ch,cf); ! 267: (void) fscanf(cf,"%d",&lcount); ! 268: if(GETC(ch)!='*') ! 269: if(!feof(cf)) err(elist->cierr,112,"no star") ! 270: else err(elist->cierr,(EOF),"lread"); ! 271: } ! 272: else (void) ungetc(ch,cf); ! 273: if(GETC(ch)=='.') GETC(ch); ! 274: switch(ch) ! 275: { ! 276: case 't': ! 277: case 'T': ! 278: lx=1; ! 279: break; ! 280: case 'f': ! 281: case 'F': ! 282: lx=0; ! 283: break; ! 284: default: ! 285: if(isblnk(ch) || issep(ch) || ch==EOF) ! 286: { (void) ungetc(ch,cf); ! 287: return(0); ! 288: } ! 289: else err(elist->cierr,112,"logical"); ! 290: } ! 291: ltype=TYLONG; ! 292: lcount = 1; ! 293: while(!issep(GETC(ch)) && ch!=EOF); ! 294: (void) ungetc(ch, cf); ! 295: return(0); ! 296: } ! 297: #define BUFSIZE 128 ! 298: l_CHAR() ! 299: { int ch,size,i; ! 300: char quote,*p; ! 301: if(lcount>0) return(0); ! 302: ltype=NULL; ! 303: ! 304: GETC(ch); ! 305: if(isdigit(ch)) ! 306: { (void) ungetc(ch,cf); ! 307: (void) fscanf(cf,"%d",&lcount); ! 308: if(GETC(ch)!='*') err(elist->cierr,112,"no star"); ! 309: } ! 310: else (void) ungetc(ch,cf); ! 311: if(GETC(ch)=='\'' || ch=='"') quote=ch; ! 312: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) ! 313: { (void) ungetc(ch,cf); ! 314: return(0); ! 315: } ! 316: else err(elist->cierr,112,"no quote"); ! 317: ltype=TYCHAR; ! 318: if(lchar!=NULL) free(lchar); ! 319: size=BUFSIZE; ! 320: p=lchar=malloc((unsigned int)size); ! 321: if(lchar==NULL) err(elist->cierr,113,"no space"); ! 322: for(i=0;;) ! 323: { while(GETC(ch)!=quote && ch!='\n' ! 324: && ch!=EOF && ++i<size) *p++ = ch; ! 325: if(i==size) ! 326: { ! 327: newone: ! 328: lchar= realloc(lchar, (unsigned int)(size += BUFSIZE)); ! 329: p=lchar+i-1; ! 330: *p++ = ch; ! 331: } ! 332: else if(ch==EOF) return(EOF); ! 333: else if(ch=='\n') ! 334: { if(*(p-1) != '\\') continue; ! 335: i--; ! 336: p--; ! 337: if(++i<size) *p++ = ch; ! 338: else goto newone; ! 339: } ! 340: else if(GETC(ch)==quote) ! 341: { if(++i<size) *p++ = ch; ! 342: else goto newone; ! 343: } ! 344: else ! 345: { (void) ungetc(ch,cf); ! 346: *p++ = 0; ! 347: return(0); ! 348: } ! 349: } ! 350: } ! 351: s_rsle(a) cilist *a; ! 352: { ! 353: int n; ! 354: if(!init) f_init(); ! 355: if(n=c_le(a)) return(n); ! 356: reading=1; ! 357: external=1; ! 358: formatted=1; ! 359: l_first=1; ! 360: l_comma = 1; ! 361: lioproc = l_read; ! 362: lquit = 0; ! 363: lcount = 0; ! 364: if(curunit->uwrt) ! 365: return(nowreading(curunit)); ! 366: else return(0); ! 367: } ! 368: c_le(a) cilist *a; ! 369: { ! 370: fmtbuf="list io"; ! 371: if(a->ciunit>=MXUNIT || a->ciunit<0) ! 372: err(a->cierr,101,"stler"); ! 373: scale=recpos=0; ! 374: elist=a; ! 375: curunit = &units[a->ciunit]; ! 376: if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) ! 377: err(a->cierr,102,"lio"); ! 378: cf=curunit->ufd; ! 379: if(!curunit->ufmt) err(a->cierr,103,"lio") ! 380: return(0); ! 381: } ! 382: do_lio(type,number,ptr,len) ftnint *number,*type; flex *ptr; ftnlen len; ! 383: { ! 384: return((*lioproc)(number,ptr,len,*type)); ! 385: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.