![[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] / 42BSD / usr.lib / libI77|
Return to lread.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.lib / libI77 |
1.1 ! root 1: /* ! 2: char id_lread[] = "@(#)lread.c 1.7"; ! 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: ltype = NULL; ! 56: if(curunit->uwrt && ! nowreading(curunit)) err(errflag, errno, lrd) ! 57: return(OK); ! 58: } ! 59: ! 60: t_getc() ! 61: { int ch; ! 62: if(curunit->uend) return(EOF); ! 63: if((ch=getc(cf))!=EOF) return(ch); ! 64: if(feof(cf)) ! 65: { curunit->uend = YES; ! 66: leof = EOF; ! 67: } ! 68: else clearerr(cf); ! 69: return(EOF); ! 70: } ! 71: ! 72: e_rsle() ! 73: { ! 74: int ch; ! 75: if(curunit->uend) return(OK); ! 76: while(GETC(ch) != '\n' && ch != EOF); ! 77: return(OK); ! 78: } ! 79: ! 80: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len; ! 81: { int i,n,ch; ! 82: double *yy; ! 83: float *xx; ! 84: for(i=0;i<*number;i++) ! 85: { ! 86: if(leof) err(endflag, EOF, lrd) ! 87: if(l_first) ! 88: { l_first = NO; ! 89: while(isblnk(GETC(ch))); /* skip blanks */ ! 90: (*ungetn)(ch,cf); ! 91: } ! 92: else if(lcount==0) /* repeat count == 0 ? */ ! 93: { ERR(t_sep()); /* look for non-blank, allow 1 comma */ ! 94: if(lquit) return(OK); /* slash found */ ! 95: } ! 96: switch((int)type) ! 97: { ! 98: case TYSHORT: ! 99: case TYLONG: ! 100: case TYREAL: ! 101: case TYDREAL: ! 102: ERR(l_R(1)); ! 103: break; ! 104: case TYCOMPLEX: ! 105: case TYDCOMPLEX: ! 106: ERR(l_C()); ! 107: break; ! 108: case TYLOGICAL: ! 109: ERR(l_L()); ! 110: break; ! 111: case TYCHAR: ! 112: ERR(l_CHAR()); ! 113: break; ! 114: } ! 115: if(lquit) return(OK); ! 116: if(leof) err(endflag,EOF,lrd) ! 117: else if(external && ferror(cf)) err(errflag,errno,lrd) ! 118: if(ltype) 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++ = ly; ! 136: *xx = lx; ! 137: break; ! 138: case TYDCOMPLEX: ! 139: yy=(double *)ptr; ! 140: *yy++ = ly; ! 141: *yy = lx; ! 142: break; ! 143: case TYCHAR: ! 144: b_char(lchar,(char *)ptr,len); ! 145: break; ! 146: } ! 147: if(lcount>0) lcount--; ! 148: ptr = (flex *)((char *)ptr + len); ! 149: } ! 150: return(OK); ! 151: } ! 152: ! 153: lr_comm() ! 154: { int ch; ! 155: if(lcount) return(lcount); ! 156: ltype=NULL; ! 157: while(isblnk(GETC(ch))); ! 158: (*ungetn)(ch,cf); ! 159: if(ch==',') ! 160: { lcount=1; ! 161: return(lcount); ! 162: } ! 163: if(ch=='/') ! 164: { lquit = YES; ! 165: return(lquit); ! 166: } ! 167: else ! 168: return(OK); ! 169: } ! 170: ! 171: get_repet() ! 172: { char ch; ! 173: double lc; ! 174: if(isdigit(GETC(ch))) ! 175: { (*ungetn)(ch,cf); ! 176: rd_int(&lc); ! 177: lcount = (int)lc; ! 178: if(GETC(ch)!='*') ! 179: if(leof) return(EOF); ! 180: else return(F_ERREPT); ! 181: } ! 182: else ! 183: { lcount = 1; ! 184: (*ungetn)(ch,cf); ! 185: } ! 186: return(OK); ! 187: } ! 188: ! 189: l_R(flg) int flg; ! 190: { double a,b,c,d; ! 191: int da,db,dc,dd; ! 192: int i,ch,sign=0; ! 193: a=b=c=d=0; ! 194: da=db=dc=dd=0; ! 195: if(flg && lr_comm()) return(OK); ! 196: da=rd_int(&a); /* repeat count ? */ ! 197: if(GETC(ch)=='*') ! 198: { ! 199: if (a <= 0.) return(F_ERNREP); ! 200: lcount=(int)a; ! 201: if (nullfld()) return(OK); /* could be R* */ ! 202: db=rd_int(&b); /* whole part of number */ ! 203: } ! 204: else ! 205: { (*ungetn)(ch,cf); ! 206: db=da; ! 207: b=a; ! 208: lcount=1; ! 209: } ! 210: if(GETC(ch)=='.' && isdigit(GETC(ch))) ! 211: { (*ungetn)(ch,cf); ! 212: dc=rd_int(&c); /* fractional part of number */ ! 213: } ! 214: else ! 215: { (*ungetn)(ch,cf); ! 216: dc=0; ! 217: c=0.; ! 218: } ! 219: if(isexp(GETC(ch))) ! 220: dd=rd_int(&d); /* exponent */ ! 221: else if (ch == '+' || ch == '-') ! 222: { (*ungetn)(ch,cf); ! 223: dd=rd_int(&d); ! 224: } ! 225: else ! 226: { (*ungetn)(ch,cf); ! 227: dd=0; ! 228: } ! 229: if(db<0 || b<0) ! 230: { sign=1; ! 231: b = -b; ! 232: } ! 233: for(i=0;i<dc;i++) c/=10.; ! 234: b=b+c; ! 235: if (dd > 0) ! 236: { for(i=0;i<d;i++) b *= 10.; ! 237: for(i=0;i< -d;i++) b /= 10.; ! 238: } ! 239: lx=sign?-b:b; ! 240: ltype=TYLONG; ! 241: return(OK); ! 242: } ! 243: ! 244: rd_int(x) double *x; ! 245: { int ch,sign=0,i=0; ! 246: double y=0.0; ! 247: if(GETC(ch)=='-') sign = -1; ! 248: else if(ch=='+') sign=0; ! 249: else (*ungetn)(ch,cf); ! 250: while(isdigit(GETC(ch))) ! 251: { i++; ! 252: y=10*y + ch-'0'; ! 253: } ! 254: (*ungetn)(ch,cf); ! 255: if(sign) y = -y; ! 256: *x = y; ! 257: return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */ ! 258: } ! 259: ! 260: l_C() ! 261: { int ch,n; ! 262: if(lr_comm()) return(OK); ! 263: if(n=get_repet()) return(n); /* get repeat count */ ! 264: if (nullfld()) return(OK); /* could be R* */ ! 265: if(GETC(ch)!='(') err(errflag,F_ERLIO,"no (") ! 266: while(isblnk(GETC(ch))); ! 267: (*ungetn)(ch,cf); ! 268: l_R(0); /* get real part */ ! 269: ly = lx; ! 270: if(t_sep()) return(EOF); ! 271: l_R(0); /* get imag part */ ! 272: while(isblnk(GETC(ch))); ! 273: if(ch!=')') err(errflag,F_ERLIO,"no )") ! 274: ltype = TYCOMPLEX; ! 275: return(OK); ! 276: } ! 277: ! 278: l_L() ! 279: { ! 280: int ch,n; ! 281: if(lr_comm()) return(OK); ! 282: if(n=get_repet()) return(n); /* get repeat count */ ! 283: if (nullfld()) return(OK); /* could be R* */ ! 284: if(GETC(ch)=='.') GETC(ch); ! 285: switch(ch) ! 286: { ! 287: case 't': ! 288: case 'T': ! 289: lx=1; ! 290: break; ! 291: case 'f': ! 292: case 'F': ! 293: lx=0; ! 294: break; ! 295: default: ! 296: if(isblnk(ch) || issep(ch)) ! 297: { (*ungetn)(ch,cf); ! 298: lx=0; ! 299: return(OK); ! 300: } ! 301: else if(ch==EOF) return(EOF); ! 302: else err(errflag,F_ERLIO,"logical not T or F"); ! 303: } ! 304: ltype=TYLOGICAL; ! 305: while(!issep(GETC(ch)) && !isblnk(ch) && !endlinp(ch)); ! 306: (*ungetn)(ch,cf); ! 307: return(OK); ! 308: } ! 309: ! 310: #define BUFSIZE 128 ! 311: l_CHAR() ! 312: { int ch,size,i,n; ! 313: char quote,*p; ! 314: if(lr_comm()) return(OK); ! 315: if(n=get_repet()) return(n); /* get repeat count */ ! 316: if (nullfld()) return(OK); /* could be R* */ ! 317: if(isapos(GETC(ch))) quote=ch; ! 318: else if(isblnk(ch) || issep(ch) || ch==EOF || ch=='\n') ! 319: { if(ch==EOF) return(EOF); ! 320: (*ungetn)(ch,cf); ! 321: return(OK); ! 322: } ! 323: else ! 324: { quote = '\0'; /* to allow single word non-quoted */ ! 325: (*ungetn)(ch,cf); ! 326: } ! 327: ltype=TYCHAR; ! 328: if(lchar!=NULL) free(lchar); ! 329: size=BUFSIZE-1; ! 330: p=lchar=(char *)malloc(BUFSIZE); ! 331: if(lchar==NULL) err(errflag,F_ERSPACE,lrd) ! 332: for(i=0;;) ! 333: { while( ( (quote && GETC(ch)!=quote) || ! 334: (!quote && !issep(GETC(ch)) && !isblnk(ch) && !endlinp(ch)) ) ! 335: && ch!='\n' && ch!=EOF && ++i<size ) ! 336: *p++ = ch; ! 337: if(i==size) ! 338: { ! 339: newone: ! 340: size += BUFSIZE; ! 341: lchar=(char *)realloc(lchar, size+1); ! 342: if(lchar==NULL) err(errflag,F_ERSPACE,lrd) ! 343: p=lchar+i-1; ! 344: *p++ = ch; ! 345: } ! 346: else if(ch==EOF) return(EOF); ! 347: else if(ch=='\n') ! 348: { if(*(p-1) == '\\') *(p-1) = ch; ! 349: else if(!quote) ! 350: { *p = '\0'; ! 351: (*ungetn)(ch,cf); ! 352: return(OK); ! 353: } ! 354: } ! 355: else if(quote && GETC(ch)==quote) ! 356: { if(++i<size) *p++ = ch; ! 357: else goto newone; ! 358: } ! 359: else ! 360: { (*ungetn)(ch,cf); ! 361: *p = '\0'; ! 362: return(OK); ! 363: } ! 364: } ! 365: } ! 366: ! 367: t_sep() ! 368: { ! 369: int ch; ! 370: while(isblnk(GETC(ch))); ! 371: if(leof) return(EOF); ! 372: if(ch=='/') ! 373: { lquit = YES; ! 374: (*ungetn)(ch,cf); ! 375: return(OK); ! 376: } ! 377: if(issep(ch)) while(isblnk(GETC(ch))); ! 378: if(leof) return(EOF); ! 379: (*ungetn)(ch,cf); ! 380: return(OK); ! 381: } ! 382: ! 383: nullfld() /* look for null field following a repeat count */ ! 384: { ! 385: int ch; ! 386: ! 387: while(isblnk(GETC(ch))); ! 388: (*ungetn)(ch,cf); ! 389: if (issep(ch) || endlinp(ch)) ! 390: return(YES); ! 391: return(NO); ! 392: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.