![[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] / 3BSD / new / libI77uc|
Return to lread.c CVS log | Up to [CSRG BSD Unix] / 3BSD / new / libI77uc |
1.1 ! root 1: /* ! 2: * list directed read ! 3: */ ! 4: ! 5: #include "fio.h" ! 6: #include "lio.h" ! 7: ! 8: #define isblnk(x) (ltab[x+1]&B) ! 9: #define issep(x) (ltab[x+1]&SP) ! 10: #define isapos(x) (ltab[x+1]&AP) ! 11: #define isexp(x) (ltab[x+1]&EX) ! 12: #define isdigit(x) (ltab[x+1]&D) ! 13: #define SP 1 ! 14: #define B 2 ! 15: #define AP 4 ! 16: #define EX 8 ! 17: #define D 16 ! 18: #define GETC(x) (x=(*getn)()) ! 19: ! 20: char *lrd = "list read"; ! 21: char *lchar; ! 22: double lx,ly; ! 23: int ltype; ! 24: int l_read(),t_getc(),ungetc(); ! 25: ! 26: char ltab[128+1] = ! 27: { 0, /* offset one for EOF */ ! 28: /* 0- 15 */ 0,0,AP,0,0,0,0,0,0,B,0,0,0,0,0,0, /* ^B,TAB */ ! 29: /* 16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 30: /* 32- 47 */ SP|B,0,AP,0,0,0,0,AP,0,0,0,0,SP,0,0,SP, /* space,",',comma,/ */ ! 31: /* 48- 63 */ D,D,D,D,D,D,D,D,D,D,0,0,0,0,0,0, /* digits 0-9 */ ! 32: /* 64- 79 */ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, /* D,E */ ! 33: /* 80- 95 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 34: /* 96-111 */ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, /* d,e */ ! 35: /* 112-127 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ! 36: }; ! 37: ! 38: s_rsle(a) cilist *a; /* start read sequential list external */ ! 39: { ! 40: int n; ! 41: reading = YES; ! 42: if(n=c_le(a,READ)) return(n); ! 43: l_first = YES; ! 44: lquit = NO; ! 45: lioproc = l_read; ! 46: getn = t_getc; ! 47: ungetn = ungetc; ! 48: leof = curunit->uend; ! 49: lcount = 0; ! 50: if(curunit->uwrt) nowreading(curunit); ! 51: return(OK); ! 52: } ! 53: ! 54: t_getc() ! 55: { int ch; ! 56: if(curunit->uend) return(EOF); ! 57: if((ch=getc(cf))!=EOF) return(ch); ! 58: if(feof(cf)) ! 59: { curunit->uend = YES; ! 60: leof = EOF; ! 61: } ! 62: else clearerr(cf); ! 63: return(EOF); ! 64: } ! 65: ! 66: e_rsle() ! 67: { ! 68: int ch; ! 69: if(curunit->uend) return(OK); ! 70: while((GETC(ch))!='\n' && ch!=EOF); ! 71: return(OK); ! 72: } ! 73: ! 74: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len; ! 75: { int i,n,ch; ! 76: double *yy; ! 77: float *xx; ! 78: for(i=0;i<*number;i++) ! 79: { ! 80: if(leof) err(endflag, EOF, lrd) ! 81: if(l_first) ! 82: { l_first = NO; ! 83: for(GETC(ch);isblnk(ch);GETC(ch)); /* skip blanks */ ! 84: (*ungetn)(ch,cf); ! 85: } ! 86: else if(lcount==0) /* repeat count == 0 ? */ ! 87: { ERR(t_sep()); /* look for non-blank, allow 1 comma */ ! 88: if(lquit) return(OK); /* slash found */ ! 89: } ! 90: switch((int)type) ! 91: { ! 92: case TYSHORT: ! 93: case TYLONG: ! 94: case TYREAL: ! 95: case TYDREAL: ! 96: ERR(l_R(1)); ! 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: if(lquit) return(OK); ! 110: if(leof) err(endflag,EOF,lrd) ! 111: else if(external && ferror(cf)) err(errflag,errno,lrd) ! 112: if(ltype) switch((int)type) ! 113: { ! 114: case TYSHORT: ! 115: ptr->flshort=lx; ! 116: break; ! 117: case TYLOGICAL: ! 118: case TYLONG: ! 119: ptr->flint=lx; ! 120: break; ! 121: case TYREAL: ! 122: ptr->flreal=lx; ! 123: break; ! 124: case TYDREAL: ! 125: ptr->fldouble=lx; ! 126: break; ! 127: case TYCOMPLEX: ! 128: xx=(float *)ptr; ! 129: *xx++ = ly; ! 130: *xx = lx; ! 131: break; ! 132: case TYDCOMPLEX: ! 133: yy=(double *)ptr; ! 134: *yy++ = ly; ! 135: *yy = lx; ! 136: break; ! 137: case TYCHAR: ! 138: b_char(lchar,(char *)ptr,len); ! 139: break; ! 140: } ! 141: if(lcount>0) lcount--; ! 142: ptr = (char *)ptr + len; ! 143: } ! 144: return(OK); ! 145: } ! 146: ! 147: lr_comm() ! 148: { int ch; ! 149: if(lcount) return(lcount); ! 150: ltype=NULL; ! 151: while(isblnk(GETC(ch))); ! 152: if(ch==',') ! 153: { lcount=1; ! 154: return(lcount); ! 155: } ! 156: else if(ch=='/') ! 157: { lquit = YES; ! 158: return(lquit); ! 159: } ! 160: else ! 161: { (*ungetn)(ch,cf); ! 162: return(OK); ! 163: } ! 164: } ! 165: ! 166: get_repet() ! 167: { char ch; ! 168: double lc; ! 169: if(isdigit(GETC(ch))) ! 170: { (*ungetn)(ch,cf); ! 171: rd_int(&lc); ! 172: lcount = (int)lc; ! 173: if(GETC(ch)!='*') ! 174: if(leof) return(EOF); ! 175: else return(109); ! 176: } ! 177: else ! 178: { lcount = 1; ! 179: (*ungetn)(ch,cf); ! 180: } ! 181: return(OK); ! 182: } ! 183: ! 184: l_R(flg) int flg; ! 185: { double a,b,c,d; ! 186: int i,ch,sign=0,da,db,dc; ! 187: a=b=c=d=0; ! 188: da=db=dc=0; ! 189: if(flg && lr_comm()) return(OK); ! 190: da=rd_int(&a); ! 191: if(da== -1) sign=da; ! 192: if(GETC(ch)!='*') ! 193: { (*ungetn)(ch,cf); ! 194: db=1; ! 195: b=a; ! 196: a=1; ! 197: } ! 198: else ! 199: db=rd_int(&b); ! 200: if(GETC(ch)!='.') ! 201: { dc=c=0; ! 202: (*ungetn)(ch,cf); ! 203: } ! 204: else dc=rd_int(&c); ! 205: if(isexp(GETC(ch))) db=rd_int(&d); ! 206: else ! 207: { (*ungetn)(ch,cf); ! 208: d=0; ! 209: } ! 210: lcount=a; ! 211: if(!db && !dc) ! 212: return(OK); ! 213: if(db && b<0) ! 214: { sign=1; ! 215: b = -b; ! 216: } ! 217: for(i=0;i<dc;i++) c/=10; ! 218: b=b+c; ! 219: for(i=0;i<d;i++) b *= 10; ! 220: for(i=0;i< -d;i++) b /= 10; ! 221: if(sign) b = -b; ! 222: ltype=TYLONG; ! 223: lx=b; ! 224: return(OK); ! 225: } ! 226: ! 227: rd_int(x) double *x; ! 228: { int ch,sign=0,i=0; ! 229: double y=0.0; ! 230: if(GETC(ch)=='-') sign = -1; ! 231: else if(ch=='+') sign=0; ! 232: else (*ungetn)(ch,cf); ! 233: while(isdigit(GETC(ch))) ! 234: { i++; ! 235: y=10*y + ch-'0'; ! 236: } ! 237: (*ungetn)(ch,cf); ! 238: if(sign) y = -y; ! 239: *x = y; ! 240: return(y!=0?i:sign); ! 241: } ! 242: ! 243: l_C() ! 244: { int ch,n; ! 245: if(lr_comm()) return(OK); ! 246: if(n=get_repet()) return(n); /* get repeat count */ ! 247: if(GETC(ch)!='(') err(errflag,112,"no (") ! 248: while(isblnk(GETC(ch))); ! 249: (*ungetn)(ch,cf); ! 250: l_R(0); /* get real part */ ! 251: ly = lx; ! 252: if(t_sep()) return(EOF); ! 253: l_R(0); /* get imag part */ ! 254: while(isblnk(GETC(ch))); ! 255: if(ch!=')') err(errflag,112,"no )") ! 256: ltype = TYCOMPLEX; ! 257: return(OK); ! 258: } ! 259: ! 260: l_L() ! 261: { ! 262: int ch,n; ! 263: if(lr_comm()) return(OK); ! 264: if(n=get_repet()) return(n); /* get repeat count */ ! 265: if(GETC(ch)=='.') GETC(ch); ! 266: switch(ch) ! 267: { ! 268: case 't': ! 269: case 'T': ! 270: lx=1; ! 271: break; ! 272: case 'f': ! 273: case 'F': ! 274: lx=0; ! 275: break; ! 276: default: ! 277: if(isblnk(ch) || issep(ch)) ! 278: { (*ungetn)(ch,cf); ! 279: lx=0; ! 280: return(OK); ! 281: } ! 282: else if(ch==EOF) return(EOF); ! 283: else err(errflag,112,"logical not T or F"); ! 284: } ! 285: ltype=TYLOGICAL; ! 286: while(!issep(GETC(ch)) && !isblnk(ch) && ch!='\n' && ch!=EOF); ! 287: return(OK); ! 288: } ! 289: ! 290: #define BUFSIZE 128 ! 291: l_CHAR() ! 292: { int ch,size,i,n; ! 293: char quote,*p; ! 294: if(lr_comm()) return(OK); ! 295: if(n=get_repet()) return(n); /* get repeat count */ ! 296: if(isapos(GETC(ch))) quote=ch; ! 297: else if(isblnk(ch) || issep(ch) || ch==EOF || ch=='\n') ! 298: { if(ch==EOF) return(EOF); ! 299: (*ungetn)(ch,cf); ! 300: return(OK); ! 301: } ! 302: else ! 303: { quote = '\0'; /* to allow single word non-quoted */ ! 304: (*ungetn)(ch,cf); ! 305: } ! 306: ltype=TYCHAR; ! 307: if(lchar!=NULL) free(lchar); ! 308: size=BUFSIZE-1; ! 309: p=lchar=(char *)malloc(BUFSIZE); ! 310: if(lchar==NULL) err(errflag,113,lrd) ! 311: for(i=0;;) ! 312: { while( ( (quote && GETC(ch)!=quote) || ! 313: (!quote && !issep(GETC(ch)) && !isblnk(ch) ) ) ! 314: && ch!='\n' && ch!=EOF && ++i<size ) ! 315: *p++ = ch; ! 316: if(i==size) ! 317: { ! 318: newone: ! 319: size += BUFSIZE; ! 320: lchar=(char *)realloc(lchar, size+1); ! 321: if(lchar==NULL) err(errflag,113,lrd) ! 322: p=lchar+i-1; ! 323: *p++ = ch; ! 324: } ! 325: else if(ch==EOF) return(EOF); ! 326: else if(ch=='\n') ! 327: { if(*(p-1) == '\\') *(p-1) = ch; ! 328: else if(!quote) ! 329: { *p = '\0'; ! 330: (*ungetn)(ch,cf); ! 331: return(OK); ! 332: } ! 333: } ! 334: else if(quote && GETC(ch)==quote) ! 335: { if(++i<size) *p++ = ch; ! 336: else goto newone; ! 337: } ! 338: else ! 339: { (*ungetn)(ch,cf); ! 340: *p = '\0'; ! 341: return(OK); ! 342: } ! 343: } ! 344: } ! 345: ! 346: t_sep() ! 347: { ! 348: int ch; ! 349: while(isblnk(GETC(ch))); ! 350: if(leof) return(EOF); ! 351: if(ch=='/') ! 352: { lquit = YES; ! 353: return(OK); ! 354: } ! 355: if(ch==',') while(isblnk(GETC(ch))); ! 356: if(leof) return(EOF); ! 357: (*ungetn)(ch,cf); ! 358: return(OK); ! 359: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.