![[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|
Return to lread.c CVS log | Up to [Research Unix] / researchv10dc / libI77 |
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: f__curunit->uend = l_eof = 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: errfl(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: errfl(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: errfl(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: errfl(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: errfl(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: errfl(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: errfl(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: errfl(f__elist->cierr,112,"no imaginary part"); ! 276: while(iswhit(GETC(ch))); ! 277: if(ch!=')') errfl(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: errfl(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 errfl(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 = (char *)malloc((unsigned int)size); ! 332: if(f__lchar == NULL) ! 333: errfl(f__elist->cierr,113,"no space"); ! 334: ! 335: GETC(ch); ! 336: if(isdigit(ch)) { ! 337: /* allow Fortran 8x-style unquoted string... */ ! 338: /* either find a repetition count or the string */ ! 339: f__lcount = ch - '0'; ! 340: *p++ = ch; ! 341: for(i = 1;;) { ! 342: switch(GETC(ch)) { ! 343: case '*': ! 344: if (f__lcount == 0) { ! 345: f__lcount = 1; ! 346: goto noquote; ! 347: } ! 348: p = f__lchar; ! 349: goto have_lcount; ! 350: case ',': ! 351: case ' ': ! 352: case '\t': ! 353: case '\n': ! 354: case '/': ! 355: Ungetc(ch,f__cf); ! 356: /* no break */ ! 357: case EOF: ! 358: f__lcount = 1; ! 359: f__ltype = TYCHAR; ! 360: return *p = 0; ! 361: } ! 362: if (!isdigit(ch)) { ! 363: f__lcount = 1; ! 364: goto noquote; ! 365: } ! 366: *p++ = ch; ! 367: f__lcount = 10*f__lcount + ch - '0'; ! 368: if (++i == size) { ! 369: f__lchar = (char *)realloc(f__lchar, ! 370: (unsigned int)(size += BUFSIZE)); ! 371: p = f__lchar + i; ! 372: } ! 373: } ! 374: } ! 375: else (void) Ungetc(ch,f__cf); ! 376: have_lcount: ! 377: if(GETC(ch)=='\'' || ch=='"') quote=ch; ! 378: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) ! 379: { (void) Ungetc(ch,f__cf); ! 380: return(0); ! 381: } ! 382: else { ! 383: /* Fortran 8x-style unquoted string */ ! 384: *p++ = ch; ! 385: for(i = 1;;) { ! 386: switch(GETC(ch)) { ! 387: case ',': ! 388: case ' ': ! 389: case '\t': ! 390: case '\n': ! 391: case '/': ! 392: Ungetc(ch,f__cf); ! 393: /* no break */ ! 394: case EOF: ! 395: f__ltype = TYCHAR; ! 396: return *p = 0; ! 397: } ! 398: noquote: ! 399: *p++ = ch; ! 400: if (++i == size) { ! 401: f__lchar = (char *)realloc(f__lchar, ! 402: (unsigned int)(size += BUFSIZE)); ! 403: p = f__lchar + i; ! 404: } ! 405: } ! 406: } ! 407: f__ltype=TYCHAR; ! 408: for(i=0;;) ! 409: { while(GETC(ch)!=quote && ch!='\n' ! 410: && ch!=EOF && ++i<size) *p++ = ch; ! 411: if(i==size) ! 412: { ! 413: newone: ! 414: f__lchar= (char *)realloc(f__lchar, ! 415: (unsigned int)(size += BUFSIZE)); ! 416: p=f__lchar+i-1; ! 417: *p++ = ch; ! 418: } ! 419: else if(ch==EOF) return(EOF); ! 420: else if(ch=='\n') ! 421: { if(*(p-1) != '\\') continue; ! 422: i--; ! 423: p--; ! 424: if(++i<size) *p++ = ch; ! 425: else goto newone; ! 426: } ! 427: else if(GETC(ch)==quote) ! 428: { if(++i<size) *p++ = ch; ! 429: else goto newone; ! 430: } ! 431: else ! 432: { (void) Ungetc(ch,f__cf); ! 433: *p = 0; ! 434: return(0); ! 435: } ! 436: } ! 437: } ! 438: #ifdef KR_headers ! 439: c_le(a) cilist *a; ! 440: #else ! 441: c_le(cilist *a) ! 442: #endif ! 443: { ! 444: f__fmtbuf="list io"; ! 445: if(a->ciunit>=MXUNIT || a->ciunit<0) ! 446: err(a->cierr,101,"stler"); ! 447: f__scale=f__recpos=0; ! 448: f__elist=a; ! 449: f__curunit = &f__units[a->ciunit]; ! 450: if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) ! 451: err(a->cierr,102,"lio"); ! 452: f__cf=f__curunit->ufd; ! 453: if(!f__curunit->ufmt) err(a->cierr,103,"lio") ! 454: return(0); ! 455: } ! 456: #ifdef KR_headers ! 457: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; ! 458: #else ! 459: l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) ! 460: #endif ! 461: { ! 462: #define Ptr ((flex *)ptr) ! 463: int i,n,ch; ! 464: doublereal *yy; ! 465: real *xx; ! 466: for(i=0;i<*number;i++) ! 467: { ! 468: if(f__lquit) return(0); ! 469: if(l_eof) ! 470: err(f__elist->ciend, EOF, "list in") ! 471: if(f__lcount == 0) { ! 472: f__ltype = 0; ! 473: for(;;) { ! 474: GETC(ch); ! 475: switch(ch) { ! 476: case EOF: ! 477: goto loopend; ! 478: case ' ': ! 479: case '\t': ! 480: case '\n': ! 481: continue; ! 482: case '/': ! 483: f__lquit = 1; ! 484: goto loopend; ! 485: case ',': ! 486: f__lcount = 1; ! 487: goto loopend; ! 488: default: ! 489: (void) Ungetc(ch, f__cf); ! 490: goto rddata; ! 491: } ! 492: } ! 493: } ! 494: rddata: ! 495: switch((int)type) ! 496: { ! 497: case TYINT1: ! 498: case TYSHORT: ! 499: case TYLONG: ! 500: #ifdef TYQUAD ! 501: case TYQUAD: ! 502: #endif ! 503: case TYREAL: ! 504: case TYDREAL: ! 505: ERR(l_R(0)); ! 506: break; ! 507: case TYCOMPLEX: ! 508: case TYDCOMPLEX: ! 509: ERR(l_C()); ! 510: break; ! 511: case TYLOGICAL1: ! 512: case TYLOGICAL2: ! 513: case TYLOGICAL: ! 514: ERR(l_L()); ! 515: break; ! 516: case TYCHAR: ! 517: ERR(l_CHAR()); ! 518: break; ! 519: } ! 520: while (GETC(ch) == ' ' || ch == '\t'); ! 521: if (ch != ',' || f__lcount > 1) ! 522: Ungetc(ch,f__cf); ! 523: loopend: ! 524: if(f__lquit) return(0); ! 525: if(f__cf) { ! 526: if (feof(f__cf)) ! 527: err(f__elist->ciend,(EOF),"list in") ! 528: else if(ferror(f__cf)) { ! 529: clearerr(f__cf); ! 530: errfl(f__elist->cierr,errno,"list in"); ! 531: } ! 532: } ! 533: if(f__ltype==0) goto bump; ! 534: switch((int)type) ! 535: { ! 536: case TYINT1: ! 537: case TYLOGICAL1: ! 538: Ptr->flchar = (char)f__lx; ! 539: break; ! 540: case TYLOGICAL2: ! 541: case TYSHORT: ! 542: Ptr->flshort = (short)f__lx; ! 543: break; ! 544: case TYLOGICAL: ! 545: case TYLONG: ! 546: Ptr->flint=f__lx; ! 547: break; ! 548: #ifdef TYQUAD ! 549: case TYQUAD: ! 550: Ptr->fllongint = f__lx; ! 551: break; ! 552: #endif ! 553: case TYREAL: ! 554: Ptr->flreal=f__lx; ! 555: break; ! 556: case TYDREAL: ! 557: Ptr->fldouble=f__lx; ! 558: break; ! 559: case TYCOMPLEX: ! 560: xx=(real *)ptr; ! 561: *xx++ = f__lx; ! 562: *xx = f__ly; ! 563: break; ! 564: case TYDCOMPLEX: ! 565: yy=(doublereal *)ptr; ! 566: *yy++ = f__lx; ! 567: *yy = f__ly; ! 568: break; ! 569: case TYCHAR: ! 570: b_char(f__lchar,ptr,len); ! 571: break; ! 572: } ! 573: bump: ! 574: if(f__lcount>0) f__lcount--; ! 575: ptr += len; ! 576: if (nml_read) ! 577: nml_read++; ! 578: } ! 579: return(0); ! 580: #undef Ptr ! 581: } ! 582: #ifdef KR_headers ! 583: integer s_rsle(a) cilist *a; ! 584: #else ! 585: integer s_rsle(cilist *a) ! 586: #endif ! 587: { ! 588: int n; ! 589: ! 590: if(!f__init) f_init(); ! 591: if(n=c_le(a)) return(n); ! 592: f__reading=1; ! 593: f__external=1; ! 594: f__formatted=1; ! 595: f__lioproc = l_read; ! 596: f__lquit = 0; ! 597: f__lcount = 0; ! 598: l_eof = 0; ! 599: if(f__curunit->uwrt && f__nowreading(f__curunit)) ! 600: err(a->cierr,errno,"read start"); ! 601: l_getc = t_getc; ! 602: l_ungetc = un_getc; ! 603: f__doend = xrd_SL; ! 604: return(0); ! 605: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.