home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / gnu / f2c-1993.04.28-src.lha / src / amiga / f2c-1993.04.28 / libI77 / rdfmt.c < prev    next >
C/C++ Source or Header  |  1993-04-28  |  8KB  |  477 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "fp.h"
  5.  
  6. extern int f__cursor;
  7. #ifdef KR_headers
  8. extern double atof();
  9. #else
  10. #undef abs
  11. #undef min
  12. #undef max
  13. #include "stdlib.h"
  14. #endif
  15.  
  16.  static int
  17. #ifdef KR_headers
  18. rd_Z(n,w,len) Uint *n; ftnlen len;
  19. #else
  20. rd_Z(Uint *n, int w, ftnlen len)
  21. #endif
  22. {
  23.     long x[9];
  24.     char *s, *s0, *s1, *se, *t;
  25.     int ch, i, w1, w2;
  26.     static char hex[256];
  27.     static int one = 1;
  28.     int bad = 0;
  29.  
  30.     if (!hex['0']) {
  31.         s = "0123456789";
  32.         while(ch = *s++)
  33.             hex[ch] = ch - '0' + 1;
  34.         s = "ABCDEF";
  35.         while(ch = *s++)
  36.             hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
  37.         }
  38.     s = s0 = (char *)x;
  39.     s1 = (char *)&x[4];
  40.     se = (char *)&x[8];
  41.     if (len > 4*sizeof(long))
  42.         return errno = 117;
  43.     while (w) {
  44.         GET(ch);
  45.         if (ch==',' || ch=='\n')
  46.             break;
  47.         w--;
  48.         if (ch > ' ') {
  49.             if (!hex[ch & 0xff])
  50.                 bad++;
  51.             *s++ = ch;
  52.             if (s == se) {
  53.                 /* discard excess characters */
  54.                 for(t = s0, s = s1; t < s1;)
  55.                     *t++ = *s++;
  56.                 s = s1;
  57.                 }
  58.             }
  59.         }
  60.     if (bad)
  61.         return errno = 115;
  62.     w = (int)len;
  63.     w1 = s - s0;
  64.     w2 = w1+1 >> 1;
  65.     t = (char *)n;
  66.     if (*(char *)&one) {
  67.         /* little endian */
  68.         t += w - 1;
  69.         i = -1;
  70.         }
  71.     else
  72.         i = 1;
  73.     for(; w > w2; t += i, --w)
  74.         *t = 0;
  75.     if (!w)
  76.         return 0;
  77.     if (w < w2)
  78.         s0 = s - (w << 1);
  79.     else if (w1 & 1) {
  80.         *t = hex[*s0++ & 0xff] - 1;
  81.         if (!--w)
  82.             return 0;
  83.         t += i;
  84.         }
  85.     do {
  86.         *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
  87.         t += i;
  88.         s0 += 2;
  89.         }
  90.         while(--w);
  91.     return 0;
  92.     }
  93.  
  94.  static int
  95. #ifdef KR_headers
  96. rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
  97. #else
  98. rd_I(Uint *n, int w, ftnlen len, register int base)
  99. #endif
  100. {    long x;
  101.     int sign,ch;
  102.     char s[84], *ps;
  103.     ps=s; x=0;
  104.     while (w)
  105.     {
  106.         GET(ch);
  107.         if (ch==',' || ch=='\n') break;
  108.         *ps=ch; ps++; w--;
  109.     }
  110.     *ps='\0';
  111.     ps=s;
  112.     while (*ps==' ') ps++;
  113.     if (*ps=='-') { sign=1; ps++; }
  114.     else { sign=0; if (*ps=='+') ps++; }
  115. loop:    while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
  116.     if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
  117.     if(sign) x = -x;
  118.     if(len==sizeof(integer)) n->il=x;
  119.     else if(len == sizeof(char)) n->ic = (char)x;
  120. #ifdef Allow_TYQUAD
  121.     else if (len == sizeof(longint)) n->ili = x;
  122. #endif
  123.     else n->is = (short)x;
  124.     if (*ps) return(errno=115); else return(0);
  125. }
  126.  static int
  127. #ifdef KR_headers
  128. rd_L(n,w,len) ftnint *n; ftnlen len;
  129. #else
  130. rd_L(ftnint *n, int w, ftnlen len)
  131. #endif
  132. {    int ch, lv;
  133.     char s[84], *ps;
  134.     ps=s;
  135.     while (w) {
  136.         GET(ch);
  137.         if (ch==','||ch=='\n') break;
  138.         *ps=ch;
  139.         ps++; w--;
  140.         }
  141.     *ps='\0';
  142.     ps=s; while (*ps==' ') ps++;
  143.     if (*ps=='.') ps++;
  144.     if (*ps=='t' || *ps == 'T')
  145.         lv = 1;
  146.     else if (*ps == 'f' || *ps == 'F')
  147.         lv = 0;
  148.     else return(errno=116);
  149.     switch(len) {
  150.         case sizeof(char):    *(char *)n = (char)lv;     break;
  151.         case sizeof(short):    *(short *)n = (short)lv; break;
  152.         default:        *n = lv;
  153.         }
  154.     return 0;
  155. }
  156.  
  157. #include "ctype.h"
  158.  
  159.  static int
  160. #ifdef KR_headers
  161. rd_F(p, w, d, len) ufloat *p; ftnlen len;
  162. #else
  163. rd_F(ufloat *p, int w, int d, ftnlen len)
  164. #endif
  165. {
  166.     char s[FMAX+EXPMAXDIGS+4];
  167.     register int ch;
  168.     register char *sp, *spe, *sp1;
  169.     double x;
  170.     int scale1, se;
  171.     long e, exp;
  172.  
  173.     sp1 = sp = s;
  174.     spe = sp + FMAX;
  175.     exp = -d;
  176.     x = 0.;
  177.  
  178.     do {
  179.         GET(ch);
  180.         w--;
  181.         } while (ch == ' ' && w);
  182.     switch(ch) {
  183.         case '-': *sp++ = ch; sp1++; spe++;
  184.         case '+':
  185.             if (!w) goto zero;
  186.             --w;
  187.             GET(ch);
  188.         }
  189.     while(ch == ' ') {
  190. blankdrop:
  191.         if (!w--) goto zero; GET(ch); }
  192.     while(ch == '0')
  193.         { if (!w--) goto zero; GET(ch); }
  194.     if (ch == ' ' && f__cblank)
  195.         goto blankdrop;
  196.     scale1 = f__scale;
  197.     while(isdigit(ch)) {
  198. digloop1:
  199.         if (sp < spe) *sp++ = ch;
  200.         else ++exp;
  201. digloop1e:
  202.         if (!w--) goto done;
  203.         GET(ch);
  204.         }
  205.     if (ch == ' ') {
  206.         if (f__cblank)
  207.             { ch = '0'; goto digloop1; }
  208.         goto digloop1e;
  209.         }
  210.     if (ch == '.') {
  211.         exp += d;
  212.         if (!w--) goto done;
  213.         GET(ch);
  214.         if (sp == sp1) { /* no digits yet */
  215.             while(ch == '0') {
  216. skip01:
  217.                 --exp;
  218. skip0:
  219.                 if (!w--) goto done;
  220.                 GET(ch);
  221.                 }
  222.             if (ch == ' ') {
  223.                 if (f__cblank) goto skip01;
  224.                 goto skip0;
  225.                 }
  226.             }
  227.         while(isdigit(ch)) {
  228. digloop2:
  229.             if (sp < spe)
  230.                 { *sp++ = ch; --exp; }
  231. digloop2e:
  232.             if (!w--) goto done;
  233.             GET(ch);
  234.             }
  235.         if (ch == ' ') {
  236.             if (f__cblank)
  237.                 { ch = '0'; goto digloop2; }
  238.             goto digloop2e;
  239.             }
  240.         }
  241.     switch(ch) {
  242.       default:
  243.         break;
  244.       case '-': se = 1; goto signonly;
  245.       case '+': se = 0; goto signonly;
  246.       case 'e':
  247.       case 'E':
  248.       case 'd':
  249.       case 'D':
  250.         if (!w--)
  251.             goto bad;
  252.         GET(ch);
  253.         while(ch == ' ') {
  254.             if (!w--)
  255.                 goto bad;
  256.             GET(ch);
  257.             }
  258.         se = 0;
  259.           switch(ch) {
  260.           case '-': se = 1;
  261.           case '+':
  262. signonly:
  263.             if (!w--)
  264.                 goto bad;
  265.             GET(ch);
  266.             }
  267.         while(ch == ' ') {
  268.             if (!w--)
  269.                 goto bad;
  270.             GET(ch);
  271.             }
  272.         if (!isdigit(ch))
  273.             goto bad;
  274.  
  275.         e = ch - '0';
  276.         for(;;) {
  277.             if (!w--)
  278.                 { ch = '\n'; break; }
  279.             GET(ch);
  280.             if (!isdigit(ch)) {
  281.                 if (ch == ' ') {
  282.                     if (f__cblank)
  283.                         ch = '0';
  284.                     else continue;
  285.                     }
  286.                 else
  287.                     break;
  288.                 }
  289.             e = 10*e + ch - '0';
  290.             if (e > EXPMAX && sp > sp1)
  291.                 goto bad;
  292.             }
  293.         if (se)
  294.             exp -= e;
  295.         else
  296.             exp += e;
  297.         scale1 = 0;
  298.         }
  299.     switch(ch) {
  300.       case '\n':
  301.       case ',':
  302.         break;
  303.       default:
  304. bad:
  305.         return (errno = 115);
  306.         }
  307. done:
  308.     if (sp > sp1) {
  309.         while(*--sp == '0')
  310.             ++exp;
  311.         if (exp -= scale1)
  312.             sprintf(sp+1, "e%ld", exp);
  313.         else
  314.             sp[1] = 0;
  315.         x = atof(s);
  316.         }
  317. zero:
  318.     if (len == sizeof(real))
  319.         p->pf = x;
  320.     else
  321.         p->pd = x;
  322.     return(0);
  323.     }
  324.  
  325.  
  326.  static int
  327. #ifdef KR_headers
  328. rd_A(p,len) char *p; ftnlen len;
  329. #else
  330. rd_A(char *p, ftnlen len)
  331. #endif
  332. {    int i,ch;
  333.     for(i=0;i<len;i++)
  334.     {    GET(ch);
  335.         *p++=VAL(ch);
  336.     }
  337.     return(0);
  338. }
  339.  static int
  340. #ifdef KR_headers
  341. rd_AW(p,w,len) char *p; ftnlen len;
  342. #else
  343. rd_AW(char *p, int w, ftnlen len)
  344. #endif
  345. {    int i,ch;
  346.     if(w>=len)
  347.     {    for(i=0;i<w-len;i++)
  348.             GET(ch);
  349.         for(i=0;i<len;i++)
  350.         {    GET(ch);
  351.             *p++=VAL(ch);
  352.         }
  353.         return(0);
  354.     }
  355.     for(i=0;i<w;i++)
  356.     {    GET(ch);
  357.         *p++=VAL(ch);
  358.     }
  359.     for(i=0;i<len-w;i++) *p++=' ';
  360.     return(0);
  361. }
  362.  static int
  363. #ifdef KR_headers
  364. rd_H(n,s) char *s;
  365. #else
  366. rd_H(int n, char *s)
  367. #endif
  368. {    int i,ch;
  369.     for(i=0;i<n;i++)
  370.         if((ch=(*f__getn)())<0) return(ch);
  371.         else *s++ = ch=='\n'?' ':ch;
  372.     return(1);
  373. }
  374.  static int
  375. #ifdef KR_headers
  376. rd_POS(s) char *s;
  377. #else
  378. rd_POS(char *s)
  379. #endif
  380. {    char quote;
  381.     int ch;
  382.     quote= *s++;
  383.     for(;*s;s++)
  384.         if(*s==quote && *(s+1)!=quote) break;
  385.         else if((ch=(*f__getn)())<0) return(ch);
  386.         else *s = ch=='\n'?' ':ch;
  387.     return(1);
  388. }
  389. #ifdef KR_headers
  390. rd_ed(p,ptr,len) struct f__syl *p; char *ptr; ftnlen len;
  391. #else
  392. rd_ed(struct f__syl *p, char *ptr, ftnlen len)
  393. #endif
  394. {    int ch;
  395.     for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
  396.     if(f__cursor<0)
  397.     {    if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
  398.             f__cursor = -f__recpos;    /* is this in the standard? */
  399.         if(f__external == 0) {
  400.             extern char *f__icptr;
  401.             f__icptr += f__cursor;
  402.         }
  403.         else if(f__curunit && f__curunit->useek)
  404.             (void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
  405.         else
  406.             err(f__elist->cierr,106,"fmt");
  407.         f__recpos += f__cursor;
  408.         f__cursor=0;
  409.     }
  410.     switch(p->op)
  411.     {
  412.     default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
  413.         sig_die(f__fmtbuf, 1);
  414.     case IM:
  415.     case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
  416.         break;
  417.  
  418.         /* O and OM don't work right for character, double, complex, */
  419.         /* or doublecomplex, and they differ from Fortran 90 in */
  420.         /* showing a minus sign for negative values. */
  421.  
  422.     case OM:
  423.     case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
  424.         break;
  425.     case L: ch = rd_L((ftnint *)ptr,p->p1,len);
  426.         break;
  427.     case A:    ch = rd_A(ptr,len);
  428.         break;
  429.     case AW:
  430.         ch = rd_AW(ptr,p->p1,len);
  431.         break;
  432.     case E: case EE:
  433.     case D:
  434.     case G:
  435.     case GE:
  436.     case F:    ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
  437.         break;
  438.  
  439.         /* Z and ZM assume 8-bit bytes. */
  440.  
  441.     case ZM:
  442.     case Z:
  443.         ch = rd_Z((Uint *)ptr, p->p1, len);
  444.         break;
  445.     }
  446.     if(ch == 0) return(ch);
  447.     else if(ch == EOF) return(EOF);
  448.     if (f__cf)
  449.         clearerr(f__cf);
  450.     return(errno);
  451. }
  452. #ifdef KR_headers
  453. rd_ned(p) struct f__syl *p;
  454. #else
  455. rd_ned(struct f__syl *p)
  456. #endif
  457. {
  458.     switch(p->op)
  459.     {
  460.     default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
  461.         sig_die(f__fmtbuf, 1);
  462.     case APOS:
  463.         return(rd_POS(*(char **)&p->p2));
  464.     case H:    return(rd_H(p->p1,*(char **)&p->p2));
  465.     case SLASH: return((*f__donewrec)());
  466.     case TR:
  467.     case X:    f__cursor += p->p1;
  468.         return(1);
  469.     case T: f__cursor=p->p1-f__recpos - 1;
  470.         return(1);
  471.     case TL: f__cursor -= p->p1;
  472.         if(f__cursor < -f__recpos)    /* TL1000, 1X */
  473.             f__cursor = -f__recpos;
  474.         return(1);
  475.     }
  476. }
  477.