home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / f2c / i77lib / rdfmt.c < prev    next >
C/C++ Source or Header  |  2000-06-22  |  8KB  |  474 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.     else n->is = (short)x;
  121.     if (*ps) return(errno=115); else return(0);
  122. }
  123.  static int
  124. #ifdef KR_headers
  125. rd_L(n,w,len) ftnint *n; ftnlen len;
  126. #else
  127. rd_L(ftnint *n, int w, ftnlen len)
  128. #endif
  129. {    int ch, lv;
  130.     char s[84], *ps;
  131.     ps=s;
  132.     while (w) {
  133.         GET(ch);
  134.         if (ch==','||ch=='\n') break;
  135.         *ps=ch;
  136.         ps++; w--;
  137.         }
  138.     *ps='\0';
  139.     ps=s; while (*ps==' ') ps++;
  140.     if (*ps=='.') ps++;
  141.     if (*ps=='t' || *ps == 'T')
  142.         lv = 1;
  143.     else if (*ps == 'f' || *ps == 'F')
  144.         lv = 0;
  145.     else return(errno=116);
  146.     switch(len) {
  147.         case sizeof(char):    *(char *)n = (char)lv;     break;
  148.         case sizeof(short):    *(short *)n = (short)lv; break;
  149.         default:        *n = lv;
  150.         }
  151.     return 0;
  152. }
  153.  
  154. #include "ctype.h"
  155.  
  156.  static int
  157. #ifdef KR_headers
  158. rd_F(p, w, d, len) ufloat *p; ftnlen len;
  159. #else
  160. rd_F(ufloat *p, int w, int d, ftnlen len)
  161. #endif
  162. {
  163.     char s[FMAX+EXPMAXDIGS+4];
  164.     register int ch;
  165.     register char *sp, *spe, *sp1;
  166.     double x;
  167.     int scale1, se;
  168.     long e, exp;
  169.  
  170.     sp1 = sp = s;
  171.     spe = sp + FMAX;
  172.     exp = -d;
  173.     x = 0.;
  174.  
  175.     do {
  176.         GET(ch);
  177.         w--;
  178.         } while (ch == ' ' && w);
  179.     switch(ch) {
  180.         case '-': *sp++ = ch; sp1++; spe++;
  181.         case '+':
  182.             if (!w) goto zero;
  183.             --w;
  184.             GET(ch);
  185.         }
  186.     while(ch == ' ') {
  187. blankdrop:
  188.         if (!w--) goto zero; GET(ch); }
  189.     while(ch == '0')
  190.         { if (!w--) goto zero; GET(ch); }
  191.     if (ch == ' ' && f__cblank)
  192.         goto blankdrop;
  193.     scale1 = f__scale;
  194.     while(isdigit(ch)) {
  195. digloop1:
  196.         if (sp < spe) *sp++ = ch;
  197.         else ++exp;
  198. digloop1e:
  199.         if (!w--) goto done;
  200.         GET(ch);
  201.         }
  202.     if (ch == ' ') {
  203.         if (f__cblank)
  204.             { ch = '0'; goto digloop1; }
  205.         goto digloop1e;
  206.         }
  207.     if (ch == '.') {
  208.         exp += d;
  209.         if (!w--) goto done;
  210.         GET(ch);
  211.         if (sp == sp1) { /* no digits yet */
  212.             while(ch == '0') {
  213. skip01:
  214.                 --exp;
  215. skip0:
  216.                 if (!w--) goto done;
  217.                 GET(ch);
  218.                 }
  219.             if (ch == ' ') {
  220.                 if (f__cblank) goto skip01;
  221.                 goto skip0;
  222.                 }
  223.             }
  224.         while(isdigit(ch)) {
  225. digloop2:
  226.             if (sp < spe)
  227.                 { *sp++ = ch; --exp; }
  228. digloop2e:
  229.             if (!w--) goto done;
  230.             GET(ch);
  231.             }
  232.         if (ch == ' ') {
  233.             if (f__cblank)
  234.                 { ch = '0'; goto digloop2; }
  235.             goto digloop2e;
  236.             }
  237.         }
  238.     switch(ch) {
  239.       default:
  240.         break;
  241.       case '-': se = 1; goto signonly;
  242.       case '+': se = 0; goto signonly;
  243.       case 'e':
  244.       case 'E':
  245.       case 'd':
  246.       case 'D':
  247.         if (!w--)
  248.             goto bad;
  249.         GET(ch);
  250.         while(ch == ' ') {
  251.             if (!w--)
  252.                 goto bad;
  253.             GET(ch);
  254.             }
  255.         se = 0;
  256.           switch(ch) {
  257.           case '-': se = 1;
  258.           case '+':
  259. signonly:
  260.             if (!w--)
  261.                 goto bad;
  262.             GET(ch);
  263.             }
  264.         while(ch == ' ') {
  265.             if (!w--)
  266.                 goto bad;
  267.             GET(ch);
  268.             }
  269.         if (!isdigit(ch))
  270.             goto bad;
  271.  
  272.         e = ch - '0';
  273.         for(;;) {
  274.             if (!w--)
  275.                 { ch = '\n'; break; }
  276.             GET(ch);
  277.             if (!isdigit(ch)) {
  278.                 if (ch == ' ') {
  279.                     if (f__cblank)
  280.                         ch = '0';
  281.                     else continue;
  282.                     }
  283.                 else
  284.                     break;
  285.                 }
  286.             e = 10*e + ch - '0';
  287.             if (e > EXPMAX && sp > sp1)
  288.                 goto bad;
  289.             }
  290.         if (se)
  291.             exp -= e;
  292.         else
  293.             exp += e;
  294.         scale1 = 0;
  295.         }
  296.     switch(ch) {
  297.       case '\n':
  298.       case ',':
  299.         break;
  300.       default:
  301. bad:
  302.         return (errno = 115);
  303.         }
  304. done:
  305.     if (sp > sp1) {
  306.         while(*--sp == '0')
  307.             ++exp;
  308.         if (exp -= scale1)
  309.             sprintf(sp+1, "e%ld", exp);
  310.         else
  311.             sp[1] = 0;
  312.         x = atof(s);
  313.         }
  314. zero:
  315.     if (len == sizeof(real))
  316.         p->pf = x;
  317.     else
  318.         p->pd = x;
  319.     return(0);
  320.     }
  321.  
  322.  
  323.  static int
  324. #ifdef KR_headers
  325. rd_A(p,len) char *p; ftnlen len;
  326. #else
  327. rd_A(char *p, ftnlen len)
  328. #endif
  329. {    int i,ch;
  330.     for(i=0;i<len;i++)
  331.     {    GET(ch);
  332.         *p++=VAL(ch);
  333.     }
  334.     return(0);
  335. }
  336.  static int
  337. #ifdef KR_headers
  338. rd_AW(p,w,len) char *p; ftnlen len;
  339. #else
  340. rd_AW(char *p, int w, ftnlen len)
  341. #endif
  342. {    int i,ch;
  343.     if(w>=len)
  344.     {    for(i=0;i<w-len;i++)
  345.             GET(ch);
  346.         for(i=0;i<len;i++)
  347.         {    GET(ch);
  348.             *p++=VAL(ch);
  349.         }
  350.         return(0);
  351.     }
  352.     for(i=0;i<w;i++)
  353.     {    GET(ch);
  354.         *p++=VAL(ch);
  355.     }
  356.     for(i=0;i<len-w;i++) *p++=' ';
  357.     return(0);
  358. }
  359.  static int
  360. #ifdef KR_headers
  361. rd_H(n,s) char *s;
  362. #else
  363. rd_H(int n, char *s)
  364. #endif
  365. {    int i,ch;
  366.     for(i=0;i<n;i++)
  367.         if((ch=(*f__getn)())<0) return(ch);
  368.         else *s++ = ch=='\n'?' ':ch;
  369.     return(1);
  370. }
  371.  static int
  372. #ifdef KR_headers
  373. rd_POS(s) char *s;
  374. #else
  375. rd_POS(char *s)
  376. #endif
  377. {    char quote;
  378.     int ch;
  379.     quote= *s++;
  380.     for(;*s;s++)
  381.         if(*s==quote && *(s+1)!=quote) break;
  382.         else if((ch=(*f__getn)())<0) return(ch);
  383.         else *s = ch=='\n'?' ':ch;
  384.     return(1);
  385. }
  386. #ifdef KR_headers
  387. rd_ed(p,ptr,len) struct f__syl *p; char *ptr; ftnlen len;
  388. #else
  389. rd_ed(struct f__syl *p, char *ptr, ftnlen len)
  390. #endif
  391. {    int ch;
  392.     for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
  393.     if(f__cursor<0)
  394.     {    if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
  395.             f__cursor = -f__recpos;    /* is this in the standard? */
  396.         if(f__external == 0) {
  397.             extern char *f__icptr;
  398.             f__icptr += f__cursor;
  399.         }
  400.         else if(f__curunit && f__curunit->useek)
  401.             (void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
  402.         else
  403.             err(f__elist->cierr,106,"fmt");
  404.         f__recpos += f__cursor;
  405.         f__cursor=0;
  406.     }
  407.     switch(p->op)
  408.     {
  409.     default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
  410.         sig_die(f__fmtbuf, 1);
  411.     case IM:
  412.     case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
  413.         break;
  414.  
  415.         /* O and OM don't work right for character, double, complex, */
  416.         /* or doublecomplex, and they differ from Fortran 90 in */
  417.         /* showing a minus sign for negative values. */
  418.  
  419.     case OM:
  420.     case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
  421.         break;
  422.     case L: ch = rd_L((ftnint *)ptr,p->p1,len);
  423.         break;
  424.     case A:    ch = rd_A(ptr,len);
  425.         break;
  426.     case AW:
  427.         ch = rd_AW(ptr,p->p1,len);
  428.         break;
  429.     case E: case EE:
  430.     case D:
  431.     case G:
  432.     case GE:
  433.     case F:    ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
  434.         break;
  435.  
  436.         /* Z and ZM assume 8-bit bytes. */
  437.  
  438.     case ZM:
  439.     case Z:
  440.         ch = rd_Z((Uint *)ptr, p->p1, len);
  441.         break;
  442.     }
  443.     if(ch == 0) return(ch);
  444.     else if(ch == EOF) return(EOF);
  445.     if (f__cf)
  446.         clearerr(f__cf);
  447.     return(errno);
  448. }
  449. #ifdef KR_headers
  450. rd_ned(p) struct f__syl *p;
  451. #else
  452. rd_ned(struct f__syl *p)
  453. #endif
  454. {
  455.     switch(p->op)
  456.     {
  457.     default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
  458.         sig_die(f__fmtbuf, 1);
  459.     case APOS:
  460.         return(rd_POS(*(char **)&p->p2));
  461.     case H:    return(rd_H(p->p1,*(char **)&p->p2));
  462.     case SLASH: return((*f__donewrec)());
  463.     case TR:
  464.     case X:    f__cursor += p->p1;
  465.         return(1);
  466.     case T: f__cursor=p->p1-f__recpos - 1;
  467.         return(1);
  468.     case TL: f__cursor -= p->p1;
  469.         if(f__cursor < -f__recpos)    /* TL1000, 1X */
  470.             f__cursor = -f__recpos;
  471.         return(1);
  472.     }
  473. }
  474.