lang/fortran/lib/libI77/rdfmt.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4 #include "fp.h"
   5
   6 extern int cursor;
   7 rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
   8 {       int ch;
   9         for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch);
  10         if(cursor<0)
  11         {       if(recpos+cursor < 0) /*err(elist->cierr,110,"fmt")*/
  12                         cursor = -recpos;       /* is this in the standard? */
  13                 if(external == 0) {
  14                         extern char *icptr;
  15                         icptr += cursor;
  16                 }
  17                 else if(curunit && curunit->useek)
  18                         (void) fseek(cf,(long) cursor,SEEK_CUR);
  19                 else
  20                         err(elist->cierr,106,"fmt");
  21                 recpos += cursor;
  22                 cursor=0;
  23         }
  24         switch(p->op)
  25         {
  26         default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
  27                 sig_die(fmtbuf, 1);
  28         case I: ch = (rd_I((uint *)ptr,p->p1,len, 10));
  29                 break;
  30         case IM: ch = (rd_I((uint *)ptr,p->p1,len, 10));
  31                 break;
  32         case O: ch = (rd_I((uint *)ptr, p->p1, len, 8));
  33                 break;
  34         case L: ch = (rd_L((ftnint *)ptr,p->p1));
  35                 break;
  36         case A: ch = (rd_A(ptr,len));
  37                 break;
  38         case AW:
  39                 ch = (rd_AW(ptr,p->p1,len));
  40                 break;
  41         case E: case EE:
  42         case D:
  43         case G:
  44         case GE:
  45         case F: ch = (rd_F((ufloat *)ptr,p->p1,p->p2,len));
  46                 break;
  47         }
  48         if(ch == 0) return(ch);
  49         else if(ch == EOF) return(EOF);
  50         clearerr(cf);
  51         return(errno);
  52 }
  53 rd_ned(p) struct syl *p;
  54 {
  55         switch(p->op)
  56         {
  57         default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
  58                 sig_die(fmtbuf, 1);
  59         case APOS:
  60                 return(rd_POS(*(char **)&p->p2));
  61         case H: return(rd_H(p->p1,*(char **)&p->p2));
  62         case SLASH: return((*donewrec)());
  63         case TR:
  64         case X: cursor += p->p1;
  65                 return(1);
  66         case T: cursor=p->p1-recpos - 1;
  67                 return(1);
  68         case TL: cursor -= p->p1;
  69                 if(cursor < -recpos)    /* TL1000, 1X */
  70                         cursor = -recpos;
  71                 return(1);
  72         }
  73 }
  74 rd_I(n,w,len, base) ftnlen len; uint *n; register int base;
  75 {       long x;
  76         int sign,ch;
  77         char s[84], *ps;
  78         ps=s; x=0;
  79         while (w)
  80         {
  81                 GET(ch);
  82                 if (ch==',' || ch=='\n') break;
  83                 *ps=ch; ps++; w--;
  84         }
  85         *ps='\0';
  86         ps=s;
  87         while (*ps==' ') ps++;
  88         if (*ps=='-') { sign=1; ps++; }
  89         else { sign=0; if (*ps=='+') ps++; }
  90 loop:   while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
  91         if (*ps==' ') {if (cblank) x *= base; ps++; goto loop;}
  92         if(sign) x = -x;
  93         if(len==sizeof(integer)) n->il=x;
  94         else if(len == sizeof(char)) n->ic = x;
  95         else n->is=x;
  96         if (*ps) return(errno=115); else return(0);
  97 }
  98 rd_L(n,w) ftnint *n;
  99 {       int ch;
 100         char s[84], *ps;
 101         ps=s;
 102         while (w) {
 103                 GET(ch);
 104                 if (ch==','||ch=='\n') break;
 105                 *ps=ch;
 106                 ps++; w--;
 107                 }
 108         *ps='\0';
 109         ps=s; while (*ps==' ') ps++;
 110         if (*ps=='.') ps++;
 111         if (*ps=='t' || *ps == 'T') { *n=1; return(0); }
 112         else if (*ps == 'f' || *ps == 'F') { *n=0; return(0); }
 113         else return(errno=116);
 114 }
 115
 116 #include "ctype.h"
 117
 118 rd_F(p, w, d, len)
 119 ftnlen len;
 120 ufloat *p;
 121 {
 122         char s[FMAX+EXPMAXDIGS+4];
 123         register int ch;
 124         register char *sp, *spe, *sp1;
 125         double atof(), x;
 126         int scale1, se;
 127         long e, exp;
 128
 129         sp1 = sp = s;
 130         spe = sp + FMAX;
 131         exp = -d;
 132         x = 0.;
 133
 134         do {
 135                 GET(ch);
 136                 w--;
 137                 } while (ch == ' ' && w);
 138         switch(ch) {
 139                 case '-': *sp++ = ch; sp1++; spe++;
 140                 case '+':
 141                         if (!w) goto zero;
 142                         --w;
 143                         GET(ch);
 144                 }
 145         while(ch == ' ') {
 146 blankdrop:
 147                 if (!w--) goto zero; GET(ch); }
 148         while(ch == '0')
 149                 { if (!w--) goto zero; GET(ch); }
 150         if (ch == ' ' && cblank)
 151                 goto blankdrop;
 152         scale1 = scale;
 153         while(isdigit(ch)) {
 154 digloop1:
 155                 if (sp < spe) *sp++ = ch;
 156                 else ++exp;
 157 digloop1e:
 158                 if (!w--) goto done;
 159                 GET(ch);
 160                 }
 161         if (ch == ' ') {
 162                 if (cblank)
 163                         { ch = '0'; goto digloop1; }
 164                 goto digloop1e;
 165                 }
 166         if (ch == '.') {
 167                 exp += d;
 168                 if (!w--) goto done;
 169                 GET(ch);
 170                 if (sp == sp1) { /* no digits yet */
 171                         while(ch == '0') {
 172 skip01:
 173                                 --exp;
 174 skip0:
 175                                 if (!w--) goto done;
 176                                 GET(ch);
 177                                 }
 178                         if (ch == ' ') {
 179                                 if (cblank) goto skip01;
 180                                 goto skip0;
 181                                 }
 182                         }
 183                 while(isdigit(ch)) {
 184 digloop2:
 185                         if (sp < spe)
 186                                 { *sp++ = ch; --exp; }
 187 digloop2e:
 188                         if (!w--) goto done;
 189                         GET(ch);
 190                         }
 191                 if (ch == ' ') {
 192                         if (cblank)
 193                                 { ch = '0'; goto digloop2; }
 194                         goto digloop2e;
 195                         }
 196                 }
 197         switch(ch) {
 198           default:
 199                 break;
 200           case '-': se = 1; goto signonly;
 201           case '+': se = 0; goto signonly;
 202           case 'e':
 203           case 'E':
 204           case 'd':
 205           case 'D':
 206                 if (!w--)
 207                         goto bad;
 208                 GET(ch);
 209                 while(ch == ' ') {
 210                         if (!w--)
 211                                 goto bad;
 212                         GET(ch);
 213                         }
 214                 se = 0;
 215                 switch(ch) {
 216                   case '-': se = 1;
 217                   case '+':
 218 signonly:
 219                         if (!w--)
 220                                 goto bad;
 221                         GET(ch);
 222                         }
 223                 while(ch == ' ') {
 224                         if (!w--)
 225                                 goto bad;
 226                         GET(ch);
 227                         }
 228                 if (!isdigit(ch))
 229                         goto bad;
 230
 231                 e = ch - '0';
 232                 for(;;) {
 233                         if (!w--)
 234                                 { ch = '\n'; break; }
 235                         GET(ch);
 236                         if (!isdigit(ch)) {
 237                                 if (ch == ' ') {
 238                                         if (cblank)
 239                                                 ch = '0';
 240                                         else continue;
 241                                         }
 242                                 else
 243                                         break;
 244                                 }
 245                         e = 10*e + ch - '0';
 246                         if (e > EXPMAX && sp > sp1)
 247                                 goto bad;
 248                         }
 249                 if (se)
 250                         exp -= e;
 251                 else
 252                         exp += e;
 253                 scale1 = 0;
 254                 }
 255         switch(ch) {
 256           case '\n':
 257           case ',':
 258                 break;
 259           default:
 260 bad:
 261                 return (errno = 115);
 262                 }
 263 done:
 264         if (sp > sp1) {
 265                 while(*--sp == '0')
 266                         ++exp;
 267                 if (exp -= scale1)
 268                         sprintf(sp+1, "e%ld", exp);
 269                 else
 270                         sp[1] = 0;
 271                 x = atof(s);
 272                 }
 273 zero:
 274         if (len == sizeof(real))
 275                 p->pf = x;
 276         else
 277                 p->pd = x;
 278         return(0);
 279         }
 280
 281
 282 rd_A(p,len) char *p; ftnlen len;
 283 {       int i,ch;
 284         for(i=0;i<len;i++)
 285         {       GET(ch);
 286                 *p++=VAL(ch);
 287         }
 288         return(0);
 289 }
 290 rd_AW(p,w,len) char *p; ftnlen len;
 291 {       int i,ch;
 292         if(w>=len)
 293         {       for(i=0;i<w-len;i++)
 294                         GET(ch);
 295                 for(i=0;i<len;i++)
 296                 {       GET(ch);
 297                         *p++=VAL(ch);
 298                 }
 299                 return(0);
 300         }
 301         for(i=0;i<w;i++)
 302         {       GET(ch);
 303                 *p++=VAL(ch);
 304         }
 305         for(i=0;i<len-w;i++) *p++=' ';
 306         return(0);
 307 }
 308 rd_H(n,s) char *s;
 309 {       int i,ch;
 310         for(i=0;i<n;i++)
 311                 if((ch=(*getn)())<0) return(ch);
 312                 else *s++ = ch=='\n'?' ':ch;
 313         return(1);
 314 }
 315 rd_POS(s) char *s;
 316 {       char quote;
 317         int ch;
 318         quote= *s++;
 319         for(;*s;s++)
 320                 if(*s==quote && *(s+1)!=quote) break;
 321                 else if((ch=(*getn)())<0) return(ch);
 322                 else *s = ch=='\n'?' ':ch;
 323         return(1);
 324 }