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