![[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 / old1|
Return to lread.c CVS log | Up to [Research Unix] / researchv10dc / libI77 / old1 |
1.1 ! root 1: #include "f2c.h" ! 2: #include "fio.h" ! 3: #include "fmt.h" ! 4: #include "lio.h" ! 5: #include "ctype.h" ! 6: #include "fp.h" ! 7: ! 8: extern char *f__fmtbuf; ! 9: #ifdef KR_headers ! 10: extern double atof(); ! 11: extern char *malloc(), *realloc(); ! 12: int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); ! 13: #else ! 14: #undef abs ! 15: #undef min ! 16: #undef max ! 17: #include "stdlib.h" ! 18: int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), ! 19: (*l_ungetc)(int,FILE*); ! 20: #endif ! 21: int l_eof; ! 22: ! 23: #define isblnk(x) (f__ltab[x+1]&B) ! 24: #define issep(x) (f__ltab[x+1]&SX) ! 25: #define isapos(x) (f__ltab[x+1]&AX) ! 26: #define isexp(x) (f__ltab[x+1]&EX) ! 27: #define issign(x) (f__ltab[x+1]&SG) ! 28: #define iswhit(x) (f__ltab[x+1]&WH) ! 29: #define SX 1 ! 30: #define B 2 ! 31: #define AX 4 ! 32: #define EX 8 ! 33: #define SG 16 ! 34: #define WH 32 ! 35: char f__ltab[128+1] = { /* offset one for EOF */ ! 36: 0, ! 37: 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, ! 38: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 39: SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, ! 40: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 41: 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, ! 42: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, ! 43: AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, ! 44: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ! 45: }; ! 46: ! 47: #ifdef ungetc ! 48: static int ! 49: #ifdef KR_headers ! 50: un_getc(x,f__cf) int x; FILE *f__cf; ! 51: #else ! 52: un_getc(int x, FILE *f__cf) ! 53: #endif ! 54: { return ungetc(x,f__cf); } ! 55: #else ! 56: #define un_getc ungetc ! 57: #ifdef KR_headers ! 58: extern int ungetc(); ! 59: #endif ! 60: #endif ! 61: ! 62: t_getc(Void) ! 63: { int ch; ! 64: if(f__curunit->uend) return(EOF); ! 65: if((ch=getc(f__cf))!=EOF) return(ch); ! 66: if(feof(f__cf)) ! 67: l_eof = f__curunit->uend = 1; ! 68: return(EOF); ! 69: } ! 70: integer e_rsle(Void) ! 71: { ! 72: int ch; ! 73: if(f__curunit->uend) return(0); ! 74: while((ch=t_getc())!='\n' && ch!=EOF); ! 75: return(0); ! 76: } ! 77: ! 78: flag f__lquit; ! 79: int f__lcount,f__ltype,nml_read; ! 80: char *f__lchar; ! 81: double f__lx,f__ly; ! 82: #define ERR(x) if(n=(x)) return(n) ! 83: #define GETC(x) (x=(*l_getc)()) ! 84: #define Ungetc(x,y) (*l_ungetc)(x,y) ! 85: ! 86: #ifdef KR_headers ! 87: l_R(poststar) int poststar; ! 88: #else ! 89: l_R(int poststar) ! 90: #endif ! 91: { ! 92: char s[FMAX+EXPMAXDIGS+4]; ! 93: register int ch; ! 94: register char *sp, *spe, *sp1; ! 95: long e, exp; ! 96: int havenum, havestar, se; ! 97: ! 98: if (!poststar) { ! 99: if (f__lcount > 0) ! 100: return(0); ! 101: f__lcount = 1; ! 102: } ! 103: f__ltype = 0; ! 104: exp = 0; ! 105: havestar = 0; ! 106: retry: ! 107: sp1 = sp = s; ! 108: spe = sp + FMAX; ! 109: havenum = 0; ! 110: ! 111: switch(GETC(ch)) { ! 112: case '-': *sp++ = ch; sp1++; spe++; ! 113: case '+': ! 114: GETC(ch); ! 115: } ! 116: while(ch == '0') { ! 117: ++havenum; ! 118: GETC(ch); ! 119: } ! 120: while(isdigit(ch)) { ! 121: if (sp < spe) *sp++ = ch; ! 122: else ++exp; ! 123: GETC(ch); ! 124: } ! 125: if (ch == '*' && !poststar) { ! 126: if (sp == sp1 || exp || *s == '-') { ! 127: err(f__elist->cierr,112,"bad repetition count") ! 128: } ! 129: poststar = havestar = 1; ! 130: *sp = 0; ! 131: f__lcount = atoi(s); ! 132: goto retry; ! 133: } ! 134: if (ch == '.') { ! 135: GETC(ch); ! 136: if (sp == sp1) ! 137: while(ch == '0') { ! 138: ++havenum; ! 139: --exp; ! 140: GETC(ch); ! 141: } ! 142: while(isdigit(ch)) { ! 143: if (sp < spe) ! 144: { *sp++ = ch; --exp; } ! 145: GETC(ch); ! 146: } ! 147: } ! 148: se = 0; ! 149: if (issign(ch)) ! 150: goto signonly; ! 151: if (isexp(ch)) { ! 152: GETC(ch); ! 153: if (issign(ch)) { ! 154: signonly: ! 155: if (ch == '-') se = 1; ! 156: GETC(ch); ! 157: } ! 158: if (!isdigit(ch)) { ! 159: bad: ! 160: err(f__elist->cierr,112,"exponent field") ! 161: } ! 162: ! 163: e = ch - '0'; ! 164: while(isdigit(GETC(ch))) { ! 165: e = 10*e + ch - '0'; ! 166: if (e > EXPMAX) ! 167: goto bad; ! 168: } ! 169: if (se) ! 170: exp -= e; ! 171: else ! 172: exp += e; ! 173: } ! 174: (void) Ungetc(ch, f__cf); ! 175: if (sp > sp1) { ! 176: ++havenum; ! 177: while(*--sp == '0') ! 178: ++exp; ! 179: if (exp) ! 180: sprintf(sp+1, "e%ld", exp); ! 181: else ! 182: sp[1] = 0; ! 183: f__lx = atof(s); ! 184: } ! 185: else ! 186: f__lx = 0.; ! 187: if (havenum) ! 188: f__ltype = TYLONG; ! 189: else ! 190: switch(ch) { ! 191: case ',': ! 192: case '/': ! 193: break; ! 194: default: ! 195: if (havestar && ( ch == ' ' ! 196: ||ch == '\t' ! 197: ||ch == '\n')) ! 198: break; ! 199: if (nml_read > 1) { ! 200: f__lquit = 2; ! 201: return 0; ! 202: } ! 203: err(f__elist->cierr,112,"invalid number") ! 204: } ! 205: return 0; ! 206: } ! 207: ! 208: static int ! 209: #ifdef KR_headers ! 210: rd_count(ch) register int ch; ! 211: #else ! 212: rd_count(register int ch) ! 213: #endif ! 214: { ! 215: if (ch < '0' || ch > '9') ! 216: return 1; ! 217: f__lcount = ch - '0'; ! 218: while(GETC(ch) >= '0' && ch <= '9') ! 219: f__lcount = 10*f__lcount + ch - '0'; ! 220: Ungetc(ch,f__cf); ! 221: return f__lcount <= 0; ! 222: } ! 223: ! 224: l_C(Void) ! 225: { int ch, nml_save; ! 226: double lz; ! 227: if(f__lcount>0) return(0); ! 228: f__ltype=0; ! 229: GETC(ch); ! 230: if(ch!='(') ! 231: { ! 232: if (nml_read > 1 && (ch < '0' || ch > '9')) { ! 233: Ungetc(ch,f__cf); ! 234: f__lquit = 2; ! 235: return 0; ! 236: } ! 237: if (rd_count(ch)) ! 238: if(!f__cf || !feof(f__cf)) ! 239: err(f__elist->cierr,112,"complex format") ! 240: else ! 241: err(f__elist->cierr,(EOF),"lread"); ! 242: if(GETC(ch)!='*') ! 243: { ! 244: if(!f__cf || !feof(f__cf)) ! 245: err(f__elist->cierr,112,"no star") ! 246: else ! 247: err(f__elist->cierr,(EOF),"lread"); ! 248: } ! 249: if(GETC(ch)!='(') ! 250: { Ungetc(ch,f__cf); ! 251: return(0); ! 252: } ! 253: } ! 254: else ! 255: f__lcount = 1; ! 256: while(iswhit(GETC(ch))); ! 257: Ungetc(ch,f__cf); ! 258: nml_save = nml_read; ! 259: nml_read = 0; ! 260: if (ch = l_R(1)) ! 261: return ch; ! 262: if (!f__ltype) ! 263: err(f__elist->cierr,112,"no real part"); ! 264: lz = f__lx; ! 265: while(iswhit(GETC(ch))); ! 266: if(ch!=',') ! 267: { (void) Ungetc(ch,f__cf); ! 268: err(f__elist->cierr,112,"no comma"); ! 269: } ! 270: while(iswhit(GETC(ch))); ! 271: (void) Ungetc(ch,f__cf); ! 272: if (ch = l_R(1)) ! 273: return ch; ! 274: if (!f__ltype) ! 275: err(f__elist->cierr,112,"no imaginary part"); ! 276: while(iswhit(GETC(ch))); ! 277: if(ch!=')') err(f__elist->cierr,112,"no )"); ! 278: f__ly = f__lx; ! 279: f__lx = lz; ! 280: nml_read = nml_save; ! 281: return(0); ! 282: } ! 283: l_L(Void) ! 284: { ! 285: int ch; ! 286: if(f__lcount>0) return(0); ! 287: f__ltype=0; ! 288: GETC(ch); ! 289: if(isdigit(ch)) ! 290: { ! 291: rd_count(ch); ! 292: if(GETC(ch)!='*') ! 293: if(!f__cf || !feof(f__cf)) ! 294: err(f__elist->cierr,112,"no star") ! 295: else ! 296: err(f__elist->cierr,(EOF),"lread"); ! 297: GETC(ch); ! 298: } ! 299: if(ch == '.') GETC(ch); ! 300: switch(ch) ! 301: { ! 302: case 't': ! 303: case 'T': ! 304: f__lx=1; ! 305: break; ! 306: case 'f': ! 307: case 'F': ! 308: f__lx=0; ! 309: break; ! 310: default: ! 311: if(isblnk(ch) || issep(ch) || ch==EOF) ! 312: { (void) Ungetc(ch,f__cf); ! 313: return(0); ! 314: } ! 315: else err(f__elist->cierr,112,"logical"); ! 316: } ! 317: f__ltype=TYLONG; ! 318: f__lcount = 1; ! 319: while(!issep(GETC(ch)) && ch!=EOF); ! 320: (void) Ungetc(ch, f__cf); ! 321: return(0); ! 322: } ! 323: #define BUFSIZE 128 ! 324: l_CHAR(Void) ! 325: { int ch,size,i; ! 326: char quote,*p; ! 327: if(f__lcount>0) return(0); ! 328: f__ltype=0; ! 329: if(f__lchar!=NULL) free(f__lchar); ! 330: size=BUFSIZE; ! 331: p=f__lchar=malloc((unsigned int)size); ! 332: if(f__lchar==NULL) err(f__elist->cierr,113,"no space"); ! 333: ! 334: GETC(ch); ! 335: if(isdigit(ch)) { ! 336: /* allow Fortran 8x-style unquoted string... */ ! 337: /* either find a repetition count or the string */ ! 338: f__lcount = ch - '0'; ! 339: *p++ = ch; ! 340: for(i = 1;;) { ! 341: switch(GETC(ch)) { ! 342: case '*': ! 343: if (f__lcount == 0) { ! 344: f__lcount = 1; ! 345: goto noquote; ! 346: } ! 347: p = f__lchar; ! 348: goto have_lcount; ! 349: case ',': ! 350: case ' ': ! 351: case '\t': ! 352: case '\n': ! 353: case '/': ! 354: Ungetc(ch,f__cf); ! 355: /* no break */ ! 356: case EOF: ! 357: f__lcount = 1; ! 358: f__ltype = TYCHAR; ! 359: return *p = 0; ! 360: } ! 361: if (!isdigit(ch)) { ! 362: f__lcount = 1; ! 363: goto noquote; ! 364: } ! 365: *p++ = ch; ! 366: f__lcount = 10*f__lcount + ch - '0'; ! 367: if (++i == size) { ! 368: f__lchar = realloc(f__lchar, ! 369: (unsigned int)(size += BUFSIZE)); ! 370: p = f__lchar + i; ! 371: } ! 372: } ! 373: } ! 374: else (void) Ungetc(ch,f__cf); ! 375: have_lcount: ! 376: if(GETC(ch)=='\'' || ch=='"') quote=ch; ! 377: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) ! 378: { (void) Ungetc(ch,f__cf); ! 379: return(0); ! 380: } ! 381: else { ! 382: /* Fortran 8x-style unquoted string */ ! 383: *p++ = ch; ! 384: for(i = 1;;) { ! 385: switch(GETC(ch)) { ! 386: case ',': ! 387: case ' ': ! 388: case '\t': ! 389: case '\n': ! 390: case '/': ! 391: Ungetc(ch,f__cf); ! 392: /* no break */ ! 393: case EOF: ! 394: f__ltype = TYCHAR; ! 395: return *p = 0; ! 396: } ! 397: noquote: ! 398: *p++ = ch; ! 399: if (++i == size) { ! 400: f__lchar = realloc(f__lchar, ! 401: (unsigned int)(size += BUFSIZE)); ! 402: p = f__lchar + i; ! 403: } ! 404: } ! 405: } ! 406: f__ltype=TYCHAR; ! 407: for(i=0;;) ! 408: { while(GETC(ch)!=quote && ch!='\n' ! 409: && ch!=EOF && ++i<size) *p++ = ch; ! 410: if(i==size) ! 411: { ! 412: newone: ! 413: f__lchar= realloc(f__lchar, (unsigned int)(size += BUFSIZE)); ! 414: p=f__lchar+i-1; ! 415: *p++ = ch; ! 416: } ! 417: else if(ch==EOF) return(EOF); ! 418: else if(ch=='\n') ! 419: { if(*(p-1) != '\\') continue; ! 420: i--; ! 421: p--; ! 422: if(++i<size) *p++ = ch; ! 423: else goto newone; ! 424: } ! 425: else if(GETC(ch)==quote) ! 426: { if(++i<size) *p++ = ch; ! 427: else goto newone; ! 428: } ! 429: else ! 430: { (void) Ungetc(ch,f__cf); ! 431: *p = 0; ! 432: return(0); ! 433: } ! 434: } ! 435: } ! 436: #ifdef KR_headers ! 437: c_le(a) cilist *a; ! 438: #else ! 439: c_le(cilist *a) ! 440: #endif ! 441: { ! 442: f__fmtbuf="list io"; ! 443: if(a->ciunit>=MXUNIT || a->ciunit<0) ! 444: err(a->cierr,101,"stler"); ! 445: f__scale=f__recpos=0; ! 446: f__elist=a; ! 447: f__curunit = &f__units[a->ciunit]; ! 448: if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) ! 449: err(a->cierr,102,"lio"); ! 450: f__cf=f__curunit->ufd; ! 451: if(!f__curunit->ufmt) err(a->cierr,103,"lio") ! 452: return(0); ! 453: } ! 454: #ifdef KR_headers ! 455: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; ! 456: #else ! 457: l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) ! 458: #endif ! 459: { ! 460: #define Ptr ((flex *)ptr) ! 461: int i,n,ch; ! 462: doublereal *yy; ! 463: real *xx; ! 464: for(i=0;i<*number;i++) ! 465: { ! 466: if(f__lquit) return(0); ! 467: if(l_eof) ! 468: err(f__elist->ciend, EOF, "list in") ! 469: if(f__lcount == 0) { ! 470: f__ltype = 0; ! 471: for(;;) { ! 472: GETC(ch); ! 473: switch(ch) { ! 474: case EOF: ! 475: goto loopend; ! 476: case ' ': ! 477: case '\t': ! 478: case '\n': ! 479: continue; ! 480: case '/': ! 481: f__lquit = 1; ! 482: goto loopend; ! 483: case ',': ! 484: f__lcount = 1; ! 485: goto loopend; ! 486: default: ! 487: (void) Ungetc(ch, f__cf); ! 488: goto rddata; ! 489: } ! 490: } ! 491: } ! 492: rddata: ! 493: switch((int)type) ! 494: { ! 495: case TYINT1: ! 496: case TYSHORT: ! 497: case TYLONG: ! 498: #ifdef TYQUAD ! 499: case TYQUAD: ! 500: #endif ! 501: case TYREAL: ! 502: case TYDREAL: ! 503: ERR(l_R(0)); ! 504: break; ! 505: case TYCOMPLEX: ! 506: case TYDCOMPLEX: ! 507: ERR(l_C()); ! 508: break; ! 509: case TYLOGICAL1: ! 510: case TYLOGICAL2: ! 511: case TYLOGICAL: ! 512: ERR(l_L()); ! 513: break; ! 514: case TYCHAR: ! 515: ERR(l_CHAR()); ! 516: break; ! 517: } ! 518: while (GETC(ch) == ' ' || ch == '\t'); ! 519: if (ch != ',' || f__lcount > 1) ! 520: Ungetc(ch,f__cf); ! 521: loopend: ! 522: if(f__lquit) return(0); ! 523: if(f__cf) { ! 524: if (feof(f__cf)) ! 525: err(f__elist->ciend,(EOF),"list in") ! 526: else if(ferror(f__cf)) { ! 527: clearerr(f__cf); ! 528: err(f__elist->cierr,errno,"list in") ! 529: } ! 530: } ! 531: if(f__ltype==0) goto bump; ! 532: switch((int)type) ! 533: { ! 534: case TYINT1: ! 535: case TYLOGICAL1: ! 536: Ptr->flchar = f__lx; ! 537: break; ! 538: case TYLOGICAL2: ! 539: case TYSHORT: ! 540: Ptr->flshort=f__lx; ! 541: break; ! 542: case TYLOGICAL: ! 543: case TYLONG: ! 544: Ptr->flint=f__lx; ! 545: break; ! 546: #ifdef TYQUAD ! 547: case TYQUAD: ! 548: Ptr->fllongint = f__lx; ! 549: break; ! 550: #endif ! 551: case TYREAL: ! 552: Ptr->flreal=f__lx; ! 553: break; ! 554: case TYDREAL: ! 555: Ptr->fldouble=f__lx; ! 556: break; ! 557: case TYCOMPLEX: ! 558: xx=(real *)ptr; ! 559: *xx++ = f__lx; ! 560: *xx = f__ly; ! 561: break; ! 562: case TYDCOMPLEX: ! 563: yy=(doublereal *)ptr; ! 564: *yy++ = f__lx; ! 565: *yy = f__ly; ! 566: break; ! 567: case TYCHAR: ! 568: b_char(f__lchar,ptr,len); ! 569: break; ! 570: } ! 571: bump: ! 572: if(f__lcount>0) f__lcount--; ! 573: ptr += len; ! 574: if (nml_read) ! 575: nml_read++; ! 576: } ! 577: return(0); ! 578: #undef Ptr ! 579: } ! 580: #ifdef KR_headers ! 581: integer s_rsle(a) cilist *a; ! 582: #else ! 583: integer s_rsle(cilist *a) ! 584: #endif ! 585: { ! 586: int n; ! 587: ! 588: if(!f__init) f_init(); ! 589: if(n=c_le(a)) return(n); ! 590: f__reading=1; ! 591: f__external=1; ! 592: f__formatted=1; ! 593: f__lioproc = l_read; ! 594: f__lquit = 0; ! 595: f__lcount = 0; ! 596: l_eof = 0; ! 597: if(f__curunit->uwrt && f__nowreading(f__curunit)) ! 598: err(a->cierr,errno,"read start"); ! 599: l_getc = t_getc; ! 600: l_ungetc = un_getc; ! 601: return(0); ! 602: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.