rdfmt.c
Go to the documentation of this file.
00001 #include "f2c.h"
00002 #include "fio.h"
00003 
00004 #ifdef KR_headers
00005 extern double atof();
00006 #define Const /*nothing*/
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                                 /* discard excess characters */
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                 /* little endian */
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                 /* no break */
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) { /* no digits yet */
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) /*err(elist->cierr,110,"fmt")*/
00470                         f__cursor = -f__recpos; /* is this in the standard? */
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                 /* O and OM don't work right for character, double, complex, */
00491                 /* or doublecomplex, and they differ from Fortran 90 in */
00492                 /* showing a minus sign for negative values. */
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                 /* Z and ZM assume 8-bit bytes. */
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)      /* TL1000, 1X */
00547                         f__cursor = -f__recpos;
00548                 return(1);
00549         }
00550 }
00551 #ifdef __cplusplus
00552 }
00553 #endif

swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:56