gcc/f/runtime/libI77/rdfmt.c

   1 #include <ctype.h>
   2 #include "f2c.h"
   3 #include "fio.h"
   4
   5 extern int f__cursor;
   6 #ifdef KR_headers
   7 extern double atof();
   8 #else
   9 #undef abs
  10 #undef min
  11 #undef max
  12 #include <stdlib.h>
  13 #endif
  14
  15 #include "fmt.h"
  16 #include "fp.h"
  17
  18  static int
  19 #ifdef KR_headers
  20 rd_Z(n,w,len) Uint *n; ftnlen len;
  21 #else
  22 rd_Z(Uint *n, int w, ftnlen len)
  23 #endif
  24 {
  25         long x[9];
  26         char *s, *s0, *s1, *se, *t;
  27         int ch, i, w1, w2;
  28         static char hex[256];
  29         static int one = 1;
  30         int bad = 0;
  31
  32         if (!hex['0']) {
  33                 s = "0123456789";
  34                 while(ch = *s++)
  35                         hex[ch] = ch - '0' + 1;
  36                 s = "ABCDEF";
  37                 while(ch = *s++)
  38                         hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
  39                 }
  40         s = s0 = (char *)x;
  41         s1 = (char *)&x[4];
  42         se = (char *)&x[8];
  43         if (len > 4*sizeof(long))
  44                 return errno = 117;
  45         while (w) {
  46                 GET(ch);
  47                 if (ch==',' || ch=='\n')
  48                         break;
  49                 w--;
  50                 if (ch > ' ') {
  51                         if (!hex[ch & 0xff])
  52                                 bad++;
  53                         *s++ = ch;
  54                         if (s == se) {
  55                                 /* discard excess characters */
  56                                 for(t = s0, s = s1; t < s1;)
  57                                         *t++ = *s++;
  58                                 s = s1;
  59                                 }
  60                         }
  61                 }
  62         if (bad)
  63                 return errno = 115;
  64         w = (int)len;
  65         w1 = s - s0;
  66         w2 = w1+1 >> 1;
  67         t = (char *)n;
  68         if (*(char *)&one) {
  69                 /* little endian */
  70                 t += w - 1;
  71                 i = -1;
  72                 }
  73         else
  74                 i = 1;
  75         for(; w > w2; t += i, --w)
  76                 *t = 0;
  77         if (!w)
  78                 return 0;
  79         if (w < w2)
  80                 s0 = s - (w << 1);
  81         else if (w1 & 1) {
  82                 *t = hex[*s0++ & 0xff] - 1;
  83                 if (!--w)
  84                         return 0;
  85                 t += i;
  86                 }
  87         do {
  88                 *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
  89                 t += i;
  90                 s0 += 2;
  91                 }
  92                 while(--w);
  93         return 0;
  94         }
  95
  96  static int
  97 #ifdef KR_headers
  98 rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
  99 #else
 100 rd_I(Uint *n, int w, ftnlen len, register int base)
 101 #endif
 102 {       longint x;
 103         int sign,ch;
 104         char s[84], *ps;
 105         ps=s; x=0;
 106         while (w)
 107         {
 108                 GET(ch);
 109                 if (ch==',' || ch=='\n') break;
 110                 *ps=ch; ps++; w--;
 111         }
 112         *ps='\0';
 113         ps=s;
 114         while (*ps==' ') ps++;
 115         if (*ps=='-') { sign=1; ps++; }
 116         else { sign=0; if (*ps=='+') ps++; }
 117 loop:   while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
 118         if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
 119         if(sign) x = -x;
 120         if(len==sizeof(integer)) n->il=x;
 121         else if(len == sizeof(char)) n->ic = (char)x;
 122 #ifdef Allow_TYQUAD
 123         else if (len == sizeof(longint)) n->ili = x;
 124 #endif
 125         else n->is = (short)x;
 126         if (*ps) return(errno=115); else return(0);
 127 }
 128  static int
 129 #ifdef KR_headers
 130 rd_L(n,w,len) ftnint *n; ftnlen len;
 131 #else
 132 rd_L(ftnint *n, int w, ftnlen len)
 133 #endif
 134 {       int ch, lv;
 135         char s[84], *ps;
 136         ps=s;
 137         while (w) {
 138                 GET(ch);
 139                 if (ch==','||ch=='\n') break;
 140                 *ps=ch;
 141                 ps++; w--;
 142                 }
 143         *ps='\0';
 144         ps=s; while (*ps==' ') ps++;
 145         if (*ps=='.') ps++;
 146         if (*ps=='t' || *ps == 'T')
 147                 lv = 1;
 148         else if (*ps == 'f' || *ps == 'F')
 149                 lv = 0;
 150         else return(errno=116);
 151         switch(len) {
 152                 case sizeof(char):      *(char *)n = (char)lv;   break;
 153                 case sizeof(short):     *(short *)n = (short)lv; break;
 154                 default:                *n = lv;
 155                 }
 156         return 0;
 157 }
 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 syl *p; char *ptr; ftnlen len;
 391 #else
 392 rd_ed(struct 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 syl *p;
 454 #else
 455 rd_ned(struct 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 }