scilab » libs » f2c » libf2c

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