00001 #include "stdlib.h"
00002 #include "f2c.h"
00003 #include "fio.h"
00004 #include "fmt.h"
00005 #include "lio.h"
00006 #include "ctype.h"
00007 #include "fp.h"
00008
00009 extern char *f__fmtbuf;
00010
00011 #ifdef Allow_TYQUAD
00012 static longint f__llx;
00013 static int quad_read;
00014 #endif
00015
00016 #ifdef KR_headers
00017 extern double atof();
00018 extern char *malloc(), *realloc();
00019 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
00020 #else
00021 #undef abs
00022 #undef min
00023 #undef max
00024 #include "stdlib.h"
00025 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
00026 (*l_ungetc)(int,FILE*);
00027 #endif
00028 int l_eof;
00029
00030 #define isblnk(x) (f__ltab[x+1]&B)
00031 #define issep(x) (f__ltab[x+1]&SX)
00032 #define isapos(x) (f__ltab[x+1]&AX)
00033 #define isexp(x) (f__ltab[x+1]&EX)
00034 #define issign(x) (f__ltab[x+1]&SG)
00035 #define iswhit(x) (f__ltab[x+1]&WH)
00036 #define SX 1
00037 #define B 2
00038 #define AX 4
00039 #define EX 8
00040 #define SG 16
00041 #define WH 32
00042 char f__ltab[128+1] = {
00043 0,
00044 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
00045 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
00046 SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
00047 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
00048 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
00049 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
00050 AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
00051 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
00052 };
00053
00054 #ifdef ungetc
00055 static int
00056 #ifdef KR_headers
00057 un_getc(x,f__cf) int x; FILE *f__cf;
00058 #else
00059 un_getc(int x, FILE *f__cf)
00060 #endif
00061 { return ungetc(x,f__cf); }
00062 #else
00063 #define un_getc ungetc
00064 #ifdef KR_headers
00065 extern int ungetc();
00066 #else
00067 extern int ungetc(int, FILE*);
00068 #endif
00069 #endif
00070
00071 t_getc(Void)
00072 { int ch;
00073 if(f__curunit->uend) return(EOF);
00074 if((ch=getc(f__cf))!=EOF) return(ch);
00075 if(feof(f__cf))
00076 f__curunit->uend = l_eof = 1;
00077 return(EOF);
00078 }
00079 integer e_rsle(Void)
00080 {
00081 int ch;
00082 if(f__curunit->uend) return(0);
00083 while((ch=t_getc())!='\n')
00084 if (ch == EOF) {
00085 if(feof(f__cf))
00086 f__curunit->uend = l_eof = 1;
00087 return EOF;
00088 }
00089 return(0);
00090 }
00091
00092 flag f__lquit;
00093 int f__lcount,f__ltype,nml_read;
00094 char *f__lchar;
00095 double f__lx,f__ly;
00096 #define ERR(x) if(n=(x)) return(n)
00097 #define GETC(x) (x=(*l_getc)())
00098 #define Ungetc(x,y) (*l_ungetc)(x,y)
00099
00100 #ifdef KR_headers
00101 l_R(poststar) int poststar;
00102 #else
00103 l_R(int poststar)
00104 #endif
00105 {
00106 char s[FMAX+EXPMAXDIGS+4];
00107 register int ch;
00108 register char *sp, *spe, *sp1;
00109 long e, exp;
00110 int havenum, havestar, se;
00111
00112 if (!poststar) {
00113 if (f__lcount > 0)
00114 return(0);
00115 f__lcount = 1;
00116 }
00117 #ifdef Allow_TYQUAD
00118 f__llx = 0;
00119 #endif
00120 f__ltype = 0;
00121 exp = 0;
00122 havestar = 0;
00123 retry:
00124 sp1 = sp = s;
00125 spe = sp + FMAX;
00126 havenum = 0;
00127
00128 switch(GETC(ch)) {
00129 case '-': *sp++ = ch; sp1++; spe++;
00130 case '+':
00131 GETC(ch);
00132 }
00133 while(ch == '0') {
00134 ++havenum;
00135 GETC(ch);
00136 }
00137 while(isdigit(ch)) {
00138 if (sp < spe) *sp++ = ch;
00139 else ++exp;
00140 GETC(ch);
00141 }
00142 if (ch == '*' && !poststar) {
00143 if (sp == sp1 || exp || *s == '-') {
00144 errfl(f__elist->cierr,112,"bad repetition count");
00145 }
00146 poststar = havestar = 1;
00147 *sp = 0;
00148 f__lcount = atoi(s);
00149 goto retry;
00150 }
00151 if (ch == '.') {
00152 GETC(ch);
00153 if (sp == sp1)
00154 while(ch == '0') {
00155 ++havenum;
00156 --exp;
00157 GETC(ch);
00158 }
00159 while(isdigit(ch)) {
00160 if (sp < spe)
00161 { *sp++ = ch; --exp; }
00162 GETC(ch);
00163 }
00164 }
00165 havenum += sp - sp1;
00166 se = 0;
00167 if (issign(ch))
00168 goto signonly;
00169 if (havenum && isexp(ch)) {
00170 GETC(ch);
00171 if (issign(ch)) {
00172 signonly:
00173 if (ch == '-') se = 1;
00174 GETC(ch);
00175 }
00176 if (!isdigit(ch)) {
00177 bad:
00178 errfl(f__elist->cierr,112,"exponent field");
00179 }
00180
00181 e = ch - '0';
00182 while(isdigit(GETC(ch))) {
00183 e = 10*e + ch - '0';
00184 if (e > EXPMAX)
00185 goto bad;
00186 }
00187 if (se)
00188 exp -= e;
00189 else
00190 exp += e;
00191 }
00192 (void) Ungetc(ch, f__cf);
00193 if (sp > sp1) {
00194 ++havenum;
00195 while(*--sp == '0')
00196 ++exp;
00197 if (exp)
00198 sprintf(sp+1, "e%ld", exp);
00199 else
00200 sp[1] = 0;
00201 f__lx = atof(s);
00202 #ifdef Allow_TYQUAD
00203 if (quad_read && (se = sp - sp1 + exp) > 14 && se < 20) {
00204
00205 if (exp < 0)
00206 sp += exp;
00207 if (sp1 <= sp) {
00208 f__llx = *sp1 - '0';
00209 while(++sp1 <= sp)
00210 f__llx = 10*f__llx + (*sp1 - '0');
00211 }
00212 while(--exp >= 0)
00213 f__llx *= 10;
00214 if (*s == '-')
00215 f__llx = -f__llx;
00216 }
00217 #endif
00218 }
00219 else
00220 f__lx = 0.;
00221 if (havenum)
00222 f__ltype = TYLONG;
00223 else
00224 switch(ch) {
00225 case ',':
00226 case '/':
00227 break;
00228 default:
00229 if (havestar && ( ch == ' '
00230 ||ch == '\t'
00231 ||ch == '\n'))
00232 break;
00233 if (nml_read > 1) {
00234 f__lquit = 2;
00235 return 0;
00236 }
00237 errfl(f__elist->cierr,112,"invalid number");
00238 }
00239 return 0;
00240 }
00241
00242 static int
00243 #ifdef KR_headers
00244 rd_count(ch) register int ch;
00245 #else
00246 rd_count(register int ch)
00247 #endif
00248 {
00249 if (ch < '0' || ch > '9')
00250 return 1;
00251 f__lcount = ch - '0';
00252 while(GETC(ch) >= '0' && ch <= '9')
00253 f__lcount = 10*f__lcount + ch - '0';
00254 Ungetc(ch,f__cf);
00255 return f__lcount <= 0;
00256 }
00257
00258 l_C(Void)
00259 { int ch, nml_save;
00260 double lz;
00261 if(f__lcount>0) return(0);
00262 f__ltype=0;
00263 GETC(ch);
00264 if(ch!='(')
00265 {
00266 if (nml_read > 1 && (ch < '0' || ch > '9')) {
00267 Ungetc(ch,f__cf);
00268 f__lquit = 2;
00269 return 0;
00270 }
00271 if (rd_count(ch))
00272 if(!f__cf || !feof(f__cf))
00273 errfl(f__elist->cierr,112,"complex format");
00274 else
00275 err(f__elist->cierr,(EOF),"lread");
00276 if(GETC(ch)!='*')
00277 {
00278 if(!f__cf || !feof(f__cf))
00279 errfl(f__elist->cierr,112,"no star");
00280 else
00281 err(f__elist->cierr,(EOF),"lread");
00282 }
00283 if(GETC(ch)!='(')
00284 { Ungetc(ch,f__cf);
00285 return(0);
00286 }
00287 }
00288 else
00289 f__lcount = 1;
00290 while(iswhit(GETC(ch)));
00291 Ungetc(ch,f__cf);
00292 nml_save = nml_read;
00293 nml_read = 0;
00294 if (ch = l_R(1))
00295 return ch;
00296 if (!f__ltype)
00297 errfl(f__elist->cierr,112,"no real part");
00298 lz = f__lx;
00299 while(iswhit(GETC(ch)));
00300 if(ch!=',')
00301 { (void) Ungetc(ch,f__cf);
00302 errfl(f__elist->cierr,112,"no comma");
00303 }
00304 while(iswhit(GETC(ch)));
00305 (void) Ungetc(ch,f__cf);
00306 if (ch = l_R(1))
00307 return ch;
00308 if (!f__ltype)
00309 errfl(f__elist->cierr,112,"no imaginary part");
00310 while(iswhit(GETC(ch)));
00311 if(ch!=')') errfl(f__elist->cierr,112,"no )");
00312 f__ly = f__lx;
00313 f__lx = lz;
00314 #ifdef Allow_TYQUAD
00315 f__llx = 0;
00316 #endif
00317 nml_read = nml_save;
00318 return(0);
00319 }
00320 l_L(Void)
00321 {
00322 int ch;
00323 if(f__lcount>0) return(0);
00324 f__lcount = 1;
00325 f__ltype=0;
00326 GETC(ch);
00327 if(isdigit(ch))
00328 {
00329 rd_count(ch);
00330 if(GETC(ch)!='*')
00331 if(!f__cf || !feof(f__cf))
00332 errfl(f__elist->cierr,112,"no star");
00333 else
00334 err(f__elist->cierr,(EOF),"lread");
00335 GETC(ch);
00336 }
00337 if(ch == '.') GETC(ch);
00338 switch(ch)
00339 {
00340 case 't':
00341 case 'T':
00342 f__lx=1;
00343 break;
00344 case 'f':
00345 case 'F':
00346 f__lx=0;
00347 break;
00348 default:
00349 if(isblnk(ch) || issep(ch) || ch==EOF)
00350 { (void) Ungetc(ch,f__cf);
00351 return(0);
00352 }
00353 if (nml_read > 1) {
00354 Ungetc(ch,f__cf);
00355 f__lquit = 2;
00356 return 0;
00357 }
00358 errfl(f__elist->cierr,112,"logical");
00359 }
00360 f__ltype=TYLONG;
00361 while(!issep(GETC(ch)) && ch!=EOF);
00362 (void) Ungetc(ch, f__cf);
00363 return(0);
00364 }
00365 #define BUFSIZE 128
00366 l_CHAR(Void)
00367 { int ch,size,i;
00368 static char rafail[] = "realloc failure";
00369 char quote,*p;
00370 if(f__lcount>0) return(0);
00371 f__ltype=0;
00372 if(f__lchar!=NULL) free(f__lchar);
00373 size=BUFSIZE;
00374 p=f__lchar = (char *)malloc((unsigned int)size);
00375 if(f__lchar == NULL)
00376 errfl(f__elist->cierr,113,"no space");
00377
00378 GETC(ch);
00379 if(isdigit(ch)) {
00380
00381
00382 f__lcount = ch - '0';
00383 *p++ = ch;
00384 for(i = 1;;) {
00385 switch(GETC(ch)) {
00386 case '*':
00387 if (f__lcount == 0) {
00388 f__lcount = 1;
00389 goto noquote;
00390 }
00391 p = f__lchar;
00392 goto have_lcount;
00393 case ',':
00394 case ' ':
00395 case '\t':
00396 case '\n':
00397 case '/':
00398 Ungetc(ch,f__cf);
00399
00400 case EOF:
00401 f__lcount = 1;
00402 f__ltype = TYCHAR;
00403 return *p = 0;
00404 }
00405 if (!isdigit(ch)) {
00406 f__lcount = 1;
00407 goto noquote;
00408 }
00409 *p++ = ch;
00410 f__lcount = 10*f__lcount + ch - '0';
00411 if (++i == size) {
00412 f__lchar = (char *)realloc(f__lchar,
00413 (unsigned int)(size += BUFSIZE));
00414 if(f__lchar == NULL)
00415 errfl(f__elist->cierr,113,rafail);
00416 p = f__lchar + i;
00417 }
00418 }
00419 }
00420 else (void) Ungetc(ch,f__cf);
00421 have_lcount:
00422 if(GETC(ch)=='\'' || ch=='"') quote=ch;
00423 else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
00424 { (void) Ungetc(ch,f__cf);
00425 return(0);
00426 }
00427 else {
00428
00429 *p++ = ch;
00430 for(i = 1;;) {
00431 switch(GETC(ch)) {
00432 case ',':
00433 case ' ':
00434 case '\t':
00435 case '\n':
00436 case '/':
00437 Ungetc(ch,f__cf);
00438
00439 case EOF:
00440 f__ltype = TYCHAR;
00441 return *p = 0;
00442 }
00443 noquote:
00444 *p++ = ch;
00445 if (++i == size) {
00446 f__lchar = (char *)realloc(f__lchar,
00447 (unsigned int)(size += BUFSIZE));
00448 if(f__lchar == NULL)
00449 errfl(f__elist->cierr,113,rafail);
00450 p = f__lchar + i;
00451 }
00452 }
00453 }
00454 f__ltype=TYCHAR;
00455 for(i=0;;)
00456 { while(GETC(ch)!=quote && ch!='\n'
00457 && ch!=EOF && ++i<size) *p++ = ch;
00458 if(i==size)
00459 {
00460 newone:
00461 f__lchar= (char *)realloc(f__lchar,
00462 (unsigned int)(size += BUFSIZE));
00463 if(f__lchar == NULL)
00464 errfl(f__elist->cierr,113,rafail);
00465 p=f__lchar+i-1;
00466 *p++ = ch;
00467 }
00468 else if(ch==EOF) return(EOF);
00469 else if(ch=='\n')
00470 { if(*(p-1) != '\\') continue;
00471 i--;
00472 p--;
00473 if(++i<size) *p++ = ch;
00474 else goto newone;
00475 }
00476 else if(GETC(ch)==quote)
00477 { if(++i<size) *p++ = ch;
00478 else goto newone;
00479 }
00480 else
00481 { (void) Ungetc(ch,f__cf);
00482 *p = 0;
00483 return(0);
00484 }
00485 }
00486 }
00487 #ifdef KR_headers
00488 c_le(a) cilist *a;
00489 #else
00490 c_le(cilist *a)
00491 #endif
00492 {
00493 if(!f__init)
00494 f_init();
00495 f__fmtbuf="list io";
00496 if(a->ciunit>=MXUNIT || a->ciunit<0)
00497 err(a->cierr,101,"stler");
00498 f__scale=f__recpos=0;
00499 f__elist=a;
00500 f__curunit = &f__units[a->ciunit];
00501 if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
00502 err(a->cierr,102,"lio");
00503 f__cf=f__curunit->ufd;
00504 if(!f__curunit->ufmt) err(a->cierr,103,"lio")
00505 return(0);
00506 }
00507 #ifdef KR_headers
00508 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
00509 #else
00510 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
00511 #endif
00512 {
00513 #define Ptr ((flex *)ptr)
00514 int i,n,ch;
00515 doublereal *yy;
00516 real *xx;
00517 for(i=0;i<*number;i++)
00518 {
00519 if(f__lquit) return(0);
00520 if(l_eof)
00521 err(f__elist->ciend, EOF, "list in")
00522 if(f__lcount == 0) {
00523 f__ltype = 0;
00524 for(;;) {
00525 GETC(ch);
00526 switch(ch) {
00527 case EOF:
00528 err(f__elist->ciend,(EOF),"list in")
00529 case ' ':
00530 case '\t':
00531 case '\n':
00532 continue;
00533 case '/':
00534 f__lquit = 1;
00535 goto loopend;
00536 case ',':
00537 f__lcount = 1;
00538 goto loopend;
00539 default:
00540 (void) Ungetc(ch, f__cf);
00541 goto rddata;
00542 }
00543 }
00544 }
00545 rddata:
00546 switch((int)type)
00547 {
00548 case TYINT1:
00549 case TYSHORT:
00550 case TYLONG:
00551 case TYREAL:
00552 case TYDREAL:
00553 ERR(l_R(0));
00554 break;
00555 #ifdef TYQUAD
00556 case TYQUAD:
00557 quad_read = 1;
00558 n = l_R(0);
00559 quad_read = 0;
00560 if (n)
00561 return n;
00562 break;
00563 #endif
00564 case TYCOMPLEX:
00565 case TYDCOMPLEX:
00566 ERR(l_C());
00567 break;
00568 case TYLOGICAL1:
00569 case TYLOGICAL2:
00570 case TYLOGICAL:
00571 ERR(l_L());
00572 break;
00573 case TYCHAR:
00574 ERR(l_CHAR());
00575 break;
00576 }
00577 while (GETC(ch) == ' ' || ch == '\t');
00578 if (ch != ',' || f__lcount > 1)
00579 Ungetc(ch,f__cf);
00580 loopend:
00581 if(f__lquit) return(0);
00582 if(f__cf && ferror(f__cf)) {
00583 clearerr(f__cf);
00584 errfl(f__elist->cierr,errno,"list in");
00585 }
00586 if(f__ltype==0) goto bump;
00587 switch((int)type)
00588 {
00589 case TYINT1:
00590 case TYLOGICAL1:
00591 Ptr->flchar = (char)f__lx;
00592 break;
00593 case TYLOGICAL2:
00594 case TYSHORT:
00595 Ptr->flshort = (short)f__lx;
00596 break;
00597 case TYLOGICAL:
00598 case TYLONG:
00599 Ptr->flint=f__lx;
00600 break;
00601 #ifdef Allow_TYQUAD
00602 case TYQUAD:
00603 if (!(Ptr->fllongint = f__llx))
00604 Ptr->fllongint = f__lx;
00605 break;
00606 #endif
00607 case TYREAL:
00608 Ptr->flreal=f__lx;
00609 break;
00610 case TYDREAL:
00611 Ptr->fldouble=f__lx;
00612 break;
00613 case TYCOMPLEX:
00614 xx=(real *)ptr;
00615 *xx++ = f__lx;
00616 *xx = f__ly;
00617 break;
00618 case TYDCOMPLEX:
00619 yy=(doublereal *)ptr;
00620 *yy++ = f__lx;
00621 *yy = f__ly;
00622 break;
00623 case TYCHAR:
00624 b_char(f__lchar,ptr,len);
00625 break;
00626 }
00627 bump:
00628 if(f__lcount>0) f__lcount--;
00629 ptr += len;
00630 if (nml_read)
00631 nml_read++;
00632 }
00633 return(0);
00634 #undef Ptr
00635 }
00636 #ifdef KR_headers
00637 integer s_rsle(a) cilist *a;
00638 #else
00639 integer s_rsle(cilist *a)
00640 #endif
00641 {
00642 int n;
00643
00644 if(n=c_le(a)) return(n);
00645 f__reading=1;
00646 f__external=1;
00647 f__formatted=1;
00648 f__lioproc = l_read;
00649 f__lquit = 0;
00650 f__lcount = 0;
00651 l_eof = 0;
00652 if(f__curunit->uwrt && f__nowreading(f__curunit))
00653 err(a->cierr,errno,"read start");
00654 if(f__curunit->uend)
00655 err(f__elist->ciend,(EOF),"read start");
00656 l_getc = t_getc;
00657 l_ungetc = un_getc;
00658 f__doend = xrd_SL;
00659 return(0);
00660 }
