00001 #include "f2c.h"
00002 #include "fio.h"
00003
00004 #ifdef KR_headers
00005 extern double atof();
00006 #define Const
00007 #else
00008 #define Const const
00009 #undef abs
00010 #undef min
00011 #undef max
00012 #include "stdlib.h"
00013 #endif
00014
00015 #include "fmt.h"
00016 #include "fp.h"
00017 #include "ctype.h"
00018 #ifdef __cplusplus
00019 extern "C" {
00020 #endif
00021
00022 static int
00023 #ifdef KR_headers
00024 rd_Z(n,w,len) Uint *n; ftnlen len;
00025 #else
00026 rd_Z(Uint *n, int w, ftnlen len)
00027 #endif
00028 {
00029 long x[9];
00030 char *s, *s0, *s1, *se, *t;
00031 Const char *sc;
00032 int ch, i, w1, w2;
00033 static char hex[256];
00034 static int one = 1;
00035 int bad = 0;
00036
00037 if (!hex['0']) {
00038 sc = "0123456789";
00039 while(ch = *sc++)
00040 hex[ch] = ch - '0' + 1;
00041 sc = "ABCDEF";
00042 while(ch = *sc++)
00043 hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
00044 }
00045 s = s0 = (char *)x;
00046 s1 = (char *)&x[4];
00047 se = (char *)&x[8];
00048 if (len > 4*sizeof(long))
00049 return errno = 117;
00050 while (w) {
00051 GET(ch);
00052 if (ch==',' || ch=='\n')
00053 break;
00054 w--;
00055 if (ch > ' ') {
00056 if (!hex[ch & 0xff])
00057 bad++;
00058 *s++ = ch;
00059 if (s == se) {
00060
00061 for(t = s0, s = s1; t < s1;)
00062 *t++ = *s++;
00063 s = s1;
00064 }
00065 }
00066 }
00067 if (bad)
00068 return errno = 115;
00069 w = (int)len;
00070 w1 = s - s0;
00071 w2 = w1+1 >> 1;
00072 t = (char *)n;
00073 if (*(char *)&one) {
00074
00075 t += w - 1;
00076 i = -1;
00077 }
00078 else
00079 i = 1;
00080 for(; w > w2; t += i, --w)
00081 *t = 0;
00082 if (!w)
00083 return 0;
00084 if (w < w2)
00085 s0 = s - (w << 1);
00086 else if (w1 & 1) {
00087 *t = hex[*s0++ & 0xff] - 1;
00088 if (!--w)
00089 return 0;
00090 t += i;
00091 }
00092 do {
00093 *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
00094 t += i;
00095 s0 += 2;
00096 }
00097 while(--w);
00098 return 0;
00099 }
00100
00101 static int
00102 #ifdef KR_headers
00103 rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
00104 #else
00105 rd_I(Uint *n, int w, ftnlen len, register int base)
00106 #endif
00107 {
00108 int ch, sign;
00109 longint x = 0;
00110
00111 if (w <= 0)
00112 goto have_x;
00113 for(;;) {
00114 GET(ch);
00115 if (ch != ' ')
00116 break;
00117 if (!--w)
00118 goto have_x;
00119 }
00120 sign = 0;
00121 switch(ch) {
00122 case ',':
00123 case '\n':
00124 w = 0;
00125 goto have_x;
00126 case '-':
00127 sign = 1;
00128 case '+':
00129 break;
00130 default:
00131 if (ch >= '0' && ch <= '9') {
00132 x = ch - '0';
00133 break;
00134 }
00135 goto have_x;
00136 }
00137 while(--w) {
00138 GET(ch);
00139 if (ch >= '0' && ch <= '9') {
00140 x = x*base + ch - '0';
00141 continue;
00142 }
00143 if (ch != ' ') {
00144 if (ch == '\n' || ch == ',')
00145 w = 0;
00146 break;
00147 }
00148 if (f__cblank)
00149 x *= base;
00150 }
00151 if (sign)
00152 x = -x;
00153 have_x:
00154 if(len == sizeof(integer))
00155 n->il=x;
00156 else if(len == sizeof(char))
00157 n->ic = (char)x;
00158 #ifdef Allow_TYQUAD
00159 else if (len == sizeof(longint))
00160 n->ili = x;
00161 #endif
00162 else
00163 n->is = (short)x;
00164 if (w) {
00165 while(--w)
00166 GET(ch);
00167 return errno = 115;
00168 }
00169 return 0;
00170 }
00171
00172 static int
00173 #ifdef KR_headers
00174 rd_L(n,w,len) ftnint *n; ftnlen len;
00175 #else
00176 rd_L(ftnint *n, int w, ftnlen len)
00177 #endif
00178 { int ch, dot, lv;
00179
00180 if (w <= 0)
00181 goto bad;
00182 for(;;) {
00183 GET(ch);
00184 --w;
00185 if (ch != ' ')
00186 break;
00187 if (!w)
00188 goto bad;
00189 }
00190 dot = 0;
00191 retry:
00192 switch(ch) {
00193 case '.':
00194 if (dot++ || !w)
00195 goto bad;
00196 GET(ch);
00197 --w;
00198 goto retry;
00199 case 't':
00200 case 'T':
00201 lv = 1;
00202 break;
00203 case 'f':
00204 case 'F':
00205 lv = 0;
00206 break;
00207 default:
00208 bad:
00209 for(; w > 0; --w)
00210 GET(ch);
00211
00212 case ',':
00213 case '\n':
00214 return errno = 116;
00215 }
00216 switch(len) {
00217 case sizeof(char): *(char *)n = (char)lv; break;
00218 case sizeof(short): *(short *)n = (short)lv; break;
00219 default: *n = lv;
00220 }
00221 while(w-- > 0) {
00222 GET(ch);
00223 if (ch == ',' || ch == '\n')
00224 break;
00225 }
00226 return 0;
00227 }
00228
00229 static int
00230 #ifdef KR_headers
00231 rd_F(p, w, d, len) ufloat *p; ftnlen len;
00232 #else
00233 rd_F(ufloat *p, int w, int d, ftnlen len)
00234 #endif
00235 {
00236 char s[FMAX+EXPMAXDIGS+4];
00237 register int ch;
00238 register char *sp, *spe, *sp1;
00239 double x;
00240 int scale1, se;
00241 long e, exp;
00242
00243 sp1 = sp = s;
00244 spe = sp + FMAX;
00245 exp = -d;
00246 x = 0.;
00247
00248 do {
00249 GET(ch);
00250 w--;
00251 } while (ch == ' ' && w);
00252 switch(ch) {
00253 case '-': *sp++ = ch; sp1++; spe++;
00254 case '+':
00255 if (!w) goto zero;
00256 --w;
00257 GET(ch);
00258 }
00259 while(ch == ' ') {
00260 blankdrop:
00261 if (!w--) goto zero; GET(ch); }
00262 while(ch == '0')
00263 { if (!w--) goto zero; GET(ch); }
00264 if (ch == ' ' && f__cblank)
00265 goto blankdrop;
00266 scale1 = f__scale;
00267 while(isdigit(ch)) {
00268 digloop1:
00269 if (sp < spe) *sp++ = ch;
00270 else ++exp;
00271 digloop1e:
00272 if (!w--) goto done;
00273 GET(ch);
00274 }
00275 if (ch == ' ') {
00276 if (f__cblank)
00277 { ch = '0'; goto digloop1; }
00278 goto digloop1e;
00279 }
00280 if (ch == '.') {
00281 exp += d;
00282 if (!w--) goto done;
00283 GET(ch);
00284 if (sp == sp1) {
00285 while(ch == '0') {
00286 skip01:
00287 --exp;
00288 skip0:
00289 if (!w--) goto done;
00290 GET(ch);
00291 }
00292 if (ch == ' ') {
00293 if (f__cblank) goto skip01;
00294 goto skip0;
00295 }
00296 }
00297 while(isdigit(ch)) {
00298 digloop2:
00299 if (sp < spe)
00300 { *sp++ = ch; --exp; }
00301 digloop2e:
00302 if (!w--) goto done;
00303 GET(ch);
00304 }
00305 if (ch == ' ') {
00306 if (f__cblank)
00307 { ch = '0'; goto digloop2; }
00308 goto digloop2e;
00309 }
00310 }
00311 switch(ch) {
00312 default:
00313 break;
00314 case '-': se = 1; goto signonly;
00315 case '+': se = 0; goto signonly;
00316 case 'e':
00317 case 'E':
00318 case 'd':
00319 case 'D':
00320 if (!w--)
00321 goto bad;
00322 GET(ch);
00323 while(ch == ' ') {
00324 if (!w--)
00325 goto bad;
00326 GET(ch);
00327 }
00328 se = 0;
00329 switch(ch) {
00330 case '-': se = 1;
00331 case '+':
00332 signonly:
00333 if (!w--)
00334 goto bad;
00335 GET(ch);
00336 }
00337 while(ch == ' ') {
00338 if (!w--)
00339 goto bad;
00340 GET(ch);
00341 }
00342 if (!isdigit(ch))
00343 goto bad;
00344
00345 e = ch - '0';
00346 for(;;) {
00347 if (!w--)
00348 { ch = '\n'; break; }
00349 GET(ch);
00350 if (!isdigit(ch)) {
00351 if (ch == ' ') {
00352 if (f__cblank)
00353 ch = '0';
00354 else continue;
00355 }
00356 else
00357 break;
00358 }
00359 e = 10*e + ch - '0';
00360 if (e > EXPMAX && sp > sp1)
00361 goto bad;
00362 }
00363 if (se)
00364 exp -= e;
00365 else
00366 exp += e;
00367 scale1 = 0;
00368 }
00369 switch(ch) {
00370 case '\n':
00371 case ',':
00372 break;
00373 default:
00374 bad:
00375 return (errno = 115);
00376 }
00377 done:
00378 if (sp > sp1) {
00379 while(*--sp == '0')
00380 ++exp;
00381 if (exp -= scale1)
00382 sprintf(sp+1, "e%ld", exp);
00383 else
00384 sp[1] = 0;
00385 x = atof(s);
00386 }
00387 zero:
00388 if (len == sizeof(real))
00389 p->pf = x;
00390 else
00391 p->pd = x;
00392 return(0);
00393 }
00394
00395
00396 static int
00397 #ifdef KR_headers
00398 rd_A(p,len) char *p; ftnlen len;
00399 #else
00400 rd_A(char *p, ftnlen len)
00401 #endif
00402 { int i,ch;
00403 for(i=0;i<len;i++)
00404 { GET(ch);
00405 *p++=VAL(ch);
00406 }
00407 return(0);
00408 }
00409 static int
00410 #ifdef KR_headers
00411 rd_AW(p,w,len) char *p; ftnlen len;
00412 #else
00413 rd_AW(char *p, int w, ftnlen len)
00414 #endif
00415 { int i,ch;
00416 if(w>=len)
00417 { for(i=0;i<w-len;i++)
00418 GET(ch);
00419 for(i=0;i<len;i++)
00420 { GET(ch);
00421 *p++=VAL(ch);
00422 }
00423 return(0);
00424 }
00425 for(i=0;i<w;i++)
00426 { GET(ch);
00427 *p++=VAL(ch);
00428 }
00429 for(i=0;i<len-w;i++) *p++=' ';
00430 return(0);
00431 }
00432 static int
00433 #ifdef KR_headers
00434 rd_H(n,s) char *s;
00435 #else
00436 rd_H(int n, char *s)
00437 #endif
00438 { int i,ch;
00439 for(i=0;i<n;i++)
00440 if((ch=(*f__getn)())<0) return(ch);
00441 else *s++ = ch=='\n'?' ':ch;
00442 return(1);
00443 }
00444 static int
00445 #ifdef KR_headers
00446 rd_POS(s) char *s;
00447 #else
00448 rd_POS(char *s)
00449 #endif
00450 { char quote;
00451 int ch;
00452 quote= *s++;
00453 for(;*s;s++)
00454 if(*s==quote && *(s+1)!=quote) break;
00455 else if((ch=(*f__getn)())<0) return(ch);
00456 else *s = ch=='\n'?' ':ch;
00457 return(1);
00458 }
00459
00460 int
00461 #ifdef KR_headers
00462 rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
00463 #else
00464 rd_ed(struct syl *p, char *ptr, ftnlen len)
00465 #endif
00466 { int ch;
00467 for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
00468 if(f__cursor<0)
00469 { if(f__recpos+f__cursor < 0)
00470 f__cursor = -f__recpos;
00471 if(f__external == 0) {
00472 extern char *f__icptr;
00473 f__icptr += f__cursor;
00474 }
00475 else if(f__curunit && f__curunit->useek)
00476 (void) FSEEK(f__cf, f__cursor,SEEK_CUR);
00477 else
00478 err(f__elist->cierr,106,"fmt");
00479 f__recpos += f__cursor;
00480 f__cursor=0;
00481 }
00482 switch(p->op)
00483 {
00484 default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
00485 sig_die(f__fmtbuf, 1);
00486 case IM:
00487 case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
00488 break;
00489
00490
00491
00492
00493
00494 case OM:
00495 case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
00496 break;
00497 case L: ch = rd_L((ftnint *)ptr,p->p1,len);
00498 break;
00499 case A: ch = rd_A(ptr,len);
00500 break;
00501 case AW:
00502 ch = rd_AW(ptr,p->p1,len);
00503 break;
00504 case E: case EE:
00505 case D:
00506 case G:
00507 case GE:
00508 case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len);
00509 break;
00510
00511
00512
00513 case ZM:
00514 case Z:
00515 ch = rd_Z((Uint *)ptr, p->p1, len);
00516 break;
00517 }
00518 if(ch == 0) return(ch);
00519 else if(ch == EOF) return(EOF);
00520 if (f__cf)
00521 clearerr(f__cf);
00522 return(errno);
00523 }
00524
00525 int
00526 #ifdef KR_headers
00527 rd_ned(p) struct syl *p;
00528 #else
00529 rd_ned(struct syl *p)
00530 #endif
00531 {
00532 switch(p->op)
00533 {
00534 default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
00535 sig_die(f__fmtbuf, 1);
00536 case APOS:
00537 return(rd_POS(p->p2.s));
00538 case H: return(rd_H(p->p1,p->p2.s));
00539 case SLASH: return((*f__donewrec)());
00540 case TR:
00541 case X: f__cursor += p->p1;
00542 return(1);
00543 case T: f__cursor=p->p1-f__recpos - 1;
00544 return(1);
00545 case TL: f__cursor -= p->p1;
00546 if(f__cursor < -f__recpos)
00547 f__cursor = -f__recpos;
00548 return(1);
00549 }
00550 }
00551 #ifdef __cplusplus
00552 }
00553 #endif