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