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